Ajout de theories/FSets contenant la partie "light" de FSets et FMap:

pas d'implementations par AVL, mais celles par lists, ainsi que les 
foncteurs de proprietes. 

Au passage, ajout de MoreList (complements de List) et SetoidList 
(quelques relations sur des listes considerees modulo un eq ou lt 
non standard.



git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@8628 85f007b7-540e-0410-9357-904b9bb8a0f7

18 files changed, 9279 insertions, 0 deletions

diff --git a/theories/FSets/DecidableType.v b/theories/FSets/DecidableType.v
new file mode 100644
index 000000000..56bcb680d
--- /dev/null
+++ b/theories/FSets/DecidableType.v
@@ -0,0 +1,151 @@
+(***********************************************************************)
+(*  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: DecidableType.v,v 1.3 2006/03/03 18:48:37 letouzey Exp $ *)
+
+Require Export SetoidList.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Types with decidable Equalities (but no ordering) *)
+
+Module Type DecidableType. 
+
+  Parameter t : Set.
+
+  Parameter eq : 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.
+  Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
+
+  Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.
+
+  Hint Immediate eq_sym.
+  Hint Resolve eq_refl eq_trans.
+
+End DecidableType. 
+
+
+Module PairDecidableType(D:DecidableType).
+ Import D.
+
+ Section Elt.
+ Variable elt : Set.
+ Notation key:=t.
+
+  Definition eqk (p p':key*elt) := eq (fst p) (fst p').
+  Definition eqke (p p':key*elt) := 
+          eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+  Hint Unfold eqk eqke.
+  Hint Extern 2 (eqke ?a ?b) => split.
+
+   (* eqke is stricter than eqk *)
+ 
+   Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'.
+   Proof.
+     unfold eqk, eqke; intuition.
+   Qed.
+
+  (* eqk, eqke are equalities *)
+ 
+  Lemma eqk_refl : forall e, eqk e e.
+  Proof. auto. Qed.
+
+  Lemma eqke_refl : forall e, eqke e e.
+  Proof. auto. Qed.
+
+  Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e.
+  Proof. auto. Qed.
+
+  Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e.
+  Proof. unfold eqke; intuition. Qed.
+
+  Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''.
+  Proof. eauto. Qed.
+
+  Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''.
+  Proof.
+    unfold eqke; intuition; [ eauto | congruence ].
+  Qed.
+
+  Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
+  Hint Immediate eqk_sym eqke_sym.
+
+  Lemma InA_eqke_eqk : 
+     forall x m, InA eqke x m -> InA eqk x m.
+  Proof.
+    unfold eqke; induction 1; intuition.
+  Qed.
+  Hint Resolve InA_eqke_eqk.
+
+  Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m.
+  Proof.
+   intros; apply InA_eqA with p; auto; apply eqk_trans; auto.
+  Qed.
+
+  Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
+  Definition In k m := exists e:elt, MapsTo k e m.
+
+  Hint Unfold MapsTo In.
+
+  (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)
+
+  Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
+  Proof.
+  firstorder.
+  exists x; auto.
+  induction H.
+  destruct y.
+  exists e; auto.
+  destruct IHInA as [e H0].
+  exists e; auto.
+  Qed.
+
+  Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
+  Proof.
+  intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto.
+  Qed.
+
+  Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
+  Proof.
+  destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto.
+  Qed. 
+
+  Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
+  Proof.
+    inversion 1.
+    inversion_clear H0; eauto.
+    destruct H1; simpl in *; intuition.
+  Qed.      
+
+  Lemma In_inv_2 : forall k k' e e' l, 
+      InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
+  Proof.  
+   inversion_clear 1; compute in H0; intuition.
+  Qed.
+
+  Lemma In_inv_3 : forall x x' l, 
+      InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
+  Proof.
+   inversion_clear 1; compute in H0; intuition.
+  Qed.
+
+ End Elt.
+
+ Hint Unfold eqk eqke.
+ Hint Extern 2 (eqke ?a ?b) => split.
+ Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
+ Hint Immediate eqk_sym eqke_sym.
+ Hint Resolve InA_eqke_eqk.
+ Hint Unfold MapsTo In.
+ Hint Resolve In_inv_2 In_inv_3.
+
+
+End PairDecidableType.
diff --git a/theories/FSets/FMap.v b/theories/FSets/FMap.v
new file mode 100644
index 000000000..695003968
--- /dev/null
+++ b/theories/FSets/FMap.v
@@ -0,0 +1,12 @@
+(***********************************************************************)
+(*  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: FSet.v,v 1.2 2004/12/08 19:19:24 letouzey Exp $ *)
+
+Require Export FMapInterface.
+Require Export FMapList.
diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v
new file mode 100644
index 000000000..828f5dc05
--- /dev/null
+++ b/theories/FSets/FMapInterface.v
@@ -0,0 +1,242 @@
+(***********************************************************************)
+(*  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: FMapInterface.v,v 1.13 2006/02/27 15:39:43 letouzey Exp $ *)
+
+(** * Finite map library *)  
+
+(** This file proposes an interface for finite maps *)
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+Require Import FSetInterface. 
+
+
+(** 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. 
+*)
+
+
+Module Type S.
+
+  Declare Module E : OrderedType.
+
+  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').
+
+      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.
+      
+    (** 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 : sort lt_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.
+
+
+Module Type Sord.
+ 
+  Declare Module Data : OrderedType.   
+  Declare Module MapS : S. 
+  Import MapS.
+  
+  Definition t := MapS.t Data.t. 
+
+  Parameter eq : t -> t -> Prop.
+  Parameter lt : t -> t -> Prop. 
+ 
+  Axiom eq_refl : forall m : t, eq m m.
+  Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+  Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
+  Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
+  Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
+
+  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 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. *)
+
+End Sord.
\ No newline at end of file
diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v
new file mode 100644
index 000000000..a2005c1fe
--- /dev/null
+++ b/theories/FSets/FMapList.v
@@ -0,0 +1,1271 @@
+(***********************************************************************)
+(*  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: FSetList.v,v 1.12 2006/03/10 10:49:48 letouzey Exp $ *)
+
+(** * Finite map library *)
+
+(** This file proposes an implementation of the non-dependant interface
+ [FMapInterface.S] using lists of pairs ordered (increasing) with respect to
+ left projection. *)
+
+Require Import FSetInterface. 
+Require Import FMapInterface.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Arguments Scope list [type_scope].
+
+Module Raw (X:OrderedType).
+
+Module E := X.
+Module MX := OrderedTypeFacts X.
+Module PX := PairOrderedType X.
+Import MX. 
+Import PX. 
+
+Definition key := X.t.
+Definition t (elt:Set) := list (X.t * elt).
+
+Section Elt.
+Variable elt : Set.
+
+(* Now in PairOrderedtype: 
+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.
+*)
+
+Notation eqk := (eqk (elt:=elt)).   
+Notation eqke := (eqke (elt:=elt)).
+Notation ltk := (ltk (elt:=elt)).
+Notation MapsTo := (MapsTo (elt:=elt)).
+Notation In := (In (elt:=elt)).
+Notation Sort := (sort ltk).
+Notation Inf := (lelistA (ltk)).
+
+(** * [empty] *)
+
+Definition empty : t elt := nil.
+
+Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.
+
+Lemma empty_1 : Empty empty.
+Proof.  
+ unfold Empty,empty.
+ intros a e.
+ intro abs.
+ inversion abs.
+Qed.
+Hint Resolve empty_1.
+
+Lemma empty_sorted : Sort empty.
+Proof. 
+ unfold empty; auto.
+Qed.
+
+(** * [is_empty] *)
+
+Definition is_empty (l : t elt) : bool := if l then true else false.
+
+Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. 
+Proof.
+ unfold Empty, PX.MapsTo.
+ intros m.
+ case m;auto.
+ intros (k,e) l inlist.
+ absurd (InA eqke (k, e) ((k, e) :: l));auto.
+Qed.
+
+Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+Proof.  
+ intros m.
+ case m;auto.
+ intros p l abs.
+ inversion abs.
+Qed.
+
+(** * [mem] *)
+
+Fixpoint mem (k : key) (s : t elt) {struct s} : bool :=
+ match s with
+  | nil => false
+  | (k',_) :: l =>
+     match X.compare k k' with
+      | Lt _ => false
+      | Eq _ => true
+      | Gt _ => mem k l
+     end
+ end.
+
+Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true.
+Proof.  
+ intros m Hm x; generalize Hm; clear Hm.      
+ functional induction mem x m;intros sorted belong1;trivial.
+ 
+ inversion belong1. inversion H.
+ 
+ absurd (In k ((k', e) :: l));try assumption.
+ apply Sort_Inf_NotIn with e;auto.
+
+ apply H.
+ elim (sort_inv sorted);auto.
+ elim (In_inv belong1);auto.
+ intro abs.
+ absurd (X.eq k k');auto.
+Qed. 
+
+Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. 
+Proof.
+ intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo.
+ functional induction mem x m; intros sorted hyp;try ((inversion hyp);fail).
+ exists e; auto. 
+ induction H; auto.
+ exists x; auto.
+ inversion_clear sorted; auto.
+Qed.
+
+(** * [find] *)
+
+Fixpoint find (k:key) (s: t elt) {struct s} : option elt :=
+ match s with
+  | nil => None
+  | (k',x)::s' => 
+     match X.compare k k' with
+      | Lt _ => None
+      | Eq _ => Some x
+      | Gt _ => find k s'
+     end
+ end.
+
+Lemma find_2 :  forall m x e, find x m = Some e -> MapsTo x e m.
+Proof.
+ intros m x. unfold PX.MapsTo.
+ functional induction find x m;simpl;intros e' eqfind; inversion eqfind; auto.
+Qed.
+
+Lemma find_1 :  forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. 
+Proof.
+ intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction find x m;simpl; subst; try clear H_eq_1.
+
+ inversion 2.
+
+ inversion_clear 2.
+ compute in H0; destruct H0; order.
+ generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.
+
+ inversion_clear 2.
+ compute in H0; destruct H0; intuition congruence. 
+ generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.
+ 
+ do 2 inversion_clear 1; auto.
+ compute in H3; destruct H3; order.
+Qed.
+
+(** * [add] *)
+
+Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
+ match s with
+  | nil => (k,x) :: nil
+  | (k',y) :: l =>
+     match X.compare k k' with
+      | Lt _ => (k,x)::s
+      | Eq _ => (k,x)::l
+      | Gt _ => (k',y) :: add k x l
+     end
+ end.
+
+Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m).
+Proof.
+ intros m x y e; generalize y; clear y.
+ unfold PX.MapsTo.
+ functional induction add x e m;simpl;auto.
+Qed.
+
+Lemma add_2 : forall m x y e e', 
+  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+Proof.
+ intros m x  y e e'. 
+ generalize y e; clear y e; unfold PX.MapsTo.
+ functional induction add x e' m;simpl;auto; clear H_eq_1.
+ intros y' e' eqky';  inversion_clear 1; destruct H0; simpl in *.
+ order.
+ auto.
+ auto.
+ intros y' e' eqky'; inversion_clear 1; intuition.
+Qed.
+  
+Lemma add_3 : forall m x y e e',
+  ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+Proof.
+ intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo.
+ functional induction add x e' m;simpl; intros.
+ apply (In_inv_3 H0); compute; auto.
+ apply (In_inv_3 H0); compute; auto.
+ constructor 2; apply (In_inv_3 H0); compute; auto. 
+ inversion_clear H1; auto.
+Qed.
+
+Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), 
+  Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m).
+Proof.
+ induction m.  
+ simpl; intuition.
+ intros.
+ destruct a as (x'',e'').
+ inversion_clear H.
+ compute in H0,H1.
+ simpl; case (X.compare x x''); intuition.
+Qed.
+Hint Resolve add_Inf.
+
+Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x',e').
+ simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto.
+ constructor; auto.
+ apply Inf_eq with (x',e'); auto.
+Qed.  
+
+(** * [remove] *)
+
+Fixpoint remove (k : key) (s : t elt) {struct s} : t elt :=
+ match s with
+  | nil => nil
+  | (k',x) :: l =>
+     match X.compare k k' with
+      | Lt _ => s
+      | Eq _ => l
+      | Gt _ => (k',x) :: remove k l
+     end
+ end.  
+
+Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m).
+Proof.
+ intros m Hm x y; generalize Hm; clear Hm.
+ functional induction remove x m;simpl;intros;subst;try clear H_eq_1.
+ 
+ red; inversion 1; inversion H1.
+
+ apply Sort_Inf_NotIn with x; auto.
+ constructor; compute; order.
+ 
+ inversion_clear Hm.
+ apply Sort_Inf_NotIn with x; auto. 
+ apply Inf_eq with (k',x);auto; compute; apply X.eq_trans with k; auto.
+
+ inversion_clear Hm.
+ assert (notin:~ In y (remove k l)) by auto.
+ intros (x0,abs).
+ inversion_clear abs. 
+ compute in H3; destruct H3; order.
+ apply notin; exists x0; auto.
+Qed.
+
+Lemma remove_2 : forall m (Hm:Sort m) x y e, 
+  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction remove x m;auto; try clear H_eq_1.
+ inversion_clear 3; auto.
+ compute in H1; destruct H1; order.
+ 
+ inversion_clear 1; inversion_clear 2; auto.
+Qed.
+
+Lemma remove_3 : forall m (Hm:Sort m) x y e, 
+  MapsTo y e (remove x m) -> MapsTo y e m.
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction remove x m;auto.
+ inversion_clear 1; inversion_clear 1; auto.
+Qed.
+
+Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), 
+  Inf (x',e') m -> Inf (x',e') (remove x m).
+Proof.
+ induction m.  
+ simpl; intuition.
+ intros.
+ destruct a as (x'',e'').
+ inversion_clear H.
+ compute in H0.
+ simpl; case (X.compare x x''); intuition.
+ inversion_clear Hm.
+ apply Inf_lt with (x'',e''); auto.
+Qed.
+Hint Resolve remove_Inf.
+
+Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x',e').
+ simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto.
+Qed.  
+
+(** * [elements] *)
+
+Definition elements (m: t elt) := m.
+
+Lemma elements_1 : forall m x e, 
+  MapsTo x e m -> InA eqke (x,e) (elements m).
+Proof.
+ auto.
+Qed.
+
+Lemma elements_2 : forall m x e, 
+  InA eqke (x,e) (elements m) -> MapsTo x e m.
+Proof. 
+ auto.
+Qed.
+
+Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). 
+Proof. 
+ auto.
+Qed.
+
+(** * [fold] *)
+
+Fixpoint fold (A:Set)(f:key->elt->A->A)(m:t elt) {struct m} : A -> A :=
+  fun acc => 
+  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),
+  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.
+Qed.
+
+(** * [equal] *)
+
+Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool := 
+  match m, m' with 
+   | nil, nil => true
+   | (x,e)::l, (x',e')::l' => 
+      match X.compare x x' with 
+       | Eq _ => cmp e e' && equal cmp l l'
+       | _    => false
+      end 
+   | _, _ => false 
+  end.
+
+Definition Equal cmp m m' := 
+  (forall k, In k m <-> In k m') /\ 
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).  
+
+Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, 
+  Equal cmp m m' -> equal cmp m m' = true. 
+Proof. 
+ intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
+ functional induction equal cmp m m'; simpl; auto; unfold Equal;
+ intuition; subst; try clear H_eq_3.
+
+ destruct p as (k,e).
+ destruct (H0 k).
+ destruct H2.
+ exists e; auto.
+ inversion H2.
+
+ destruct (H0 x).
+ destruct H.
+ exists e; auto.
+ inversion H.
+
+ destruct (H0 x).
+ assert (In x ((x',e')::l')). 
+  apply H; auto.
+  exists e; auto.
+ destruct (In_inv H3).
+ order.
+ inversion_clear Hm'.
+ assert (Inf (x,e) l').
+ apply Inf_lt with (x',e'); auto.
+ elim (Sort_Inf_NotIn H5 H7 H4).
+ 
+ assert (cmp e e' = true).
+  apply H2 with x; auto.
+ rewrite H0; simpl.
+ apply H; auto.
+ inversion_clear Hm; auto.
+ inversion_clear Hm'; auto.
+ unfold Equal; intuition.
+ destruct (H1 k).
+ assert (In k ((x,e) ::l)).
+  destruct H3 as (e'', hyp); exists e''; auto.
+ destruct (In_inv (H4 H6)); auto.
+ inversion_clear Hm.
+ elim (Sort_Inf_NotIn H8 H9).
+ destruct H3 as (e'', hyp); exists e''; auto.
+ apply MapsTo_eq with k; auto; order.
+ destruct (H1 k).
+ assert (In k ((x',e') ::l')).
+  destruct H3 as (e'', hyp); exists e''; auto.
+ destruct (In_inv (H5 H6)); auto.
+ inversion_clear Hm'.
+ elim (Sort_Inf_NotIn H8 H9).
+ destruct H3 as (e'', hyp); exists e''; auto.
+ apply MapsTo_eq with k; auto; order.
+ apply H2 with k; destruct (eq_dec x k); auto.
+
+ destruct (H0 x').
+ assert (In x' ((x,e)::l)). 
+  apply H2; auto.
+  exists e'; auto.
+ destruct (In_inv H3).
+ order.
+ inversion_clear Hm.
+ assert (Inf (x',e') l).
+  apply Inf_lt with (x,e); auto.
+ elim (Sort_Inf_NotIn H5 H7 H4).
+Qed.
+
+Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, 
+  equal cmp m m' = true -> Equal cmp m m'.
+Proof.
+ intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
+ functional induction equal cmp m m'; simpl; auto; unfold Equal; 
+  intuition; try discriminate; subst; try clear H_eq_3; 
+  try solve [inversion H0]; destruct (andb_prop _ _ H0); clear H0; 
+  inversion_clear Hm; inversion_clear Hm'.
+
+ destruct (H H0 H5 H3).
+ destruct (In_inv H1).
+ exists e'; constructor; split; trivial; apply X.eq_trans with x; auto.
+ destruct (H7 k).
+ destruct (H10 H9) as (e'',hyp).
+ exists e''; auto.
+
+ destruct (H H0 H5 H3).
+ destruct (In_inv H1).
+ exists e; constructor; split; trivial; apply X.eq_trans with x'; auto.
+ destruct (H7 k).
+ destruct (H11 H9) as (e'',hyp).
+ exists e''; auto.
+
+ destruct (H H0 H6 H4).
+ inversion_clear H1.
+ destruct H10; simpl in *; subst.
+ inversion_clear H2. 
+ destruct H10; simpl in *; subst; auto.
+ elim (Sort_Inf_NotIn H6 H7).
+ exists e'0; apply MapsTo_eq with k; auto; order.
+ inversion_clear H2. 
+ destruct H1; simpl in *; subst; auto.
+ elim (Sort_Inf_NotIn H0 H5).
+ exists e1; apply MapsTo_eq with k; auto; order.
+ apply H9 with k; auto.
+Qed. 
+
+(** This lemma isn't part of the spec of [Equal], 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)).
+Proof.
+ intros.
+ inversion H; subst.
+ inversion H0; subst.
+ destruct x; destruct y; compute in H1, H2.
+ split; intros.
+ apply equal_2; auto.
+ simpl.
+ elim_comp.
+ rewrite H2; simpl.
+ apply equal_1; auto.
+ apply equal_2; auto.
+ generalize (equal_1 H H0 H3).
+ simpl.
+ elim_comp.
+ rewrite H2; simpl; auto.
+Qed.
+
+Variable elt':Set.
+
+(** * [map] and [mapi] *)
+  
+Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' :=
+  match m with
+   | nil => nil
+   | (k,e)::m' => (k,f e) :: map f m'
+  end.
+
+Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' :=
+  match m with
+   | nil => nil
+   | (k,e)::m' => (k,f k e) :: mapi f m'
+  end.
+
+End Elt.
+Section Elt2. 
+(* A new section is necessary for previous definitions to work 
+   with different [elt], especially [MapsTo]... *)
+  
+Variable elt elt' : Set.
+
+(** Specification of [map] *)
+
+Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), 
+  MapsTo x e m -> MapsTo x (f e) (map f m).
+Proof.
+ intros m x e f.
+ (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
+ induction m.
+ inversion 1.
+    
+ destruct a as (x',e').
+ simpl. 
+ inversion_clear 1.
+ constructor 1.
+ unfold eqke in *; simpl in *; intuition congruence.
+ constructor 2.
+ unfold MapsTo in *; auto.
+Qed.
+
+Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), 
+  In x (map f m) -> In x m.
+Proof.
+ intros m x f. 
+ (* functional induction map elt elt' f m. *) (* Marche pas ??? *)
+ induction m; simpl.
+ intros (e,abs).
+ inversion abs.
+  
+ destruct a as (x',e).
+ intros hyp.
+ inversion hyp. clear hyp.
+ inversion H; subst; rename x0 into e'.
+ exists e; constructor.
+ unfold eqke in *; simpl in *; intuition.
+ destruct IHm as (e'',hyp).
+ exists e'; auto.
+ exists e''.
+ constructor 2; auto.
+Qed.
+
+Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'),
+  lelistA (@ltk elt) (x,e) m -> 
+  lelistA (@ltk elt') (x,e') (map f m).
+Proof. 
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x0,e0).
+ inversion_clear H; auto.
+Qed.
+
+Hint Resolve map_lelistA.
+
+Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), 
+  sort (@ltk elt') (map f m).
+Proof.   
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm.
+ constructor; auto.
+ exact (map_lelistA _ _ H0).
+Qed.      
+ 
+(** Specification of [mapi] *)
+
+Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), 
+  MapsTo x e m -> 
+  exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
+Proof.
+ intros m x e f.
+ (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
+ induction m.
+ inversion 1.
+    
+ destruct a as (x',e').
+ simpl. 
+ inversion_clear 1.
+ exists x'.
+ destruct H0; simpl in *.
+ split; auto.
+ constructor 1.
+ unfold eqke in *; simpl in *; intuition congruence.
+ destruct IHm as (y, hyp); auto.
+ exists y; intuition.
+Qed.  
+
+
+Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), 
+  In x (mapi f m) -> In x m.
+Proof.
+ intros m x f. 
+ (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
+ induction m; simpl.
+ intros (e,abs).
+ inversion abs.
+   
+ destruct a as (x',e).
+ intros hyp.
+ inversion hyp. clear hyp.
+ inversion H; subst; rename x0 into e'.
+ exists e; constructor.
+ unfold eqke in *; simpl in *; intuition.
+ destruct IHm as (e'',hyp).
+ exists e'; auto.
+ exists e''.
+ constructor 2; auto.
+Qed.
+
+Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
+  lelistA (@ltk elt) (x,e) m -> 
+  lelistA (@ltk elt') (x,f x e) (mapi f m).
+Proof. 
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear H; auto.
+Qed.
+
+Hint Resolve mapi_lelistA.
+
+Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), 
+  sort (@ltk elt') (mapi f m).
+Proof.
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm; auto.
+Qed.
+
+End Elt2. 
+Section Elt3.
+
+(** * [map2] *)
+
+Variable elt elt' elt'' : Set.
+Variable f : option elt -> option elt' -> option elt''.
+
+Definition option_cons (A:Set)(k:key)(o:option A)(l:list (key*A)) := 
+  match o with 
+   | Some e => (k,e)::l
+   | None => l
+  end.
+
+Fixpoint map2_l (m : t elt) : t elt'' := 
+  match m with 
+   | nil => nil 
+   | (k,e)::l => option_cons k (f (Some e) None) (map2_l l)
+  end. 
+
+Fixpoint map2_r (m' : t elt') : t elt'' := 
+  match m' with 
+   | nil => nil 
+   | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l')
+  end. 
+
+Fixpoint map2 (m : t elt) : t elt' -> t elt'' :=
+  match m with
+   | nil => map2_r 
+   | (k,e) :: l =>
+      fix map2_aux (m' : t elt') : t elt'' :=
+        match m' with
+         | nil => map2_l m
+         | (k',e') :: l' =>
+            match X.compare k k' with
+             | Lt _ => option_cons k (f (Some e) None) (map2 l m')
+             | Eq _ => option_cons k (f (Some e) (Some e')) (map2 l l')
+             | Gt _ => option_cons k' (f None (Some e')) (map2_aux l')
+            end
+        end
+  end.      
+
+Notation oee' := (option elt * option elt')%type.
+
+Fixpoint combine (m : t elt) : t elt' -> t oee' :=
+  match m with
+   | nil => map (fun e' => (None,Some e'))
+   | (k,e) :: l =>
+      fix combine_aux (m':t elt') : list (key * oee') :=
+        match m' with
+         | nil => map (fun e => (Some e,None)) m
+         | (k',e') :: l' =>
+            match X.compare k k' with
+             | Lt _ => (k,(Some e, None))::combine l m'
+             | Eq _ => (k,(Some e, Some e'))::combine l l'
+             | Gt _ => (k',(None,Some e'))::combine_aux l'
+            end
+        end
+  end. 
+
+Definition fold_right_pair (A B C:Set)(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' := 
+  let m0 : t oee' := combine m m' in 
+  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in 
+  fold_right_pair (option_cons (A:=elt'')) m1 nil.
+
+Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'.
+Proof.
+ unfold map2_alt.
+ induction m.
+ simpl; auto; intros.
+ (* map2_r *)
+ induction m'; try destruct a; simpl; auto.
+ rewrite IHm'; auto.
+ (* fin map2_r *)
+ induction m'; destruct a.
+ simpl; f_equal.
+ (* map2_l *)
+ clear IHm.
+ induction m; try destruct a; simpl; auto.
+ rewrite IHm; auto.
+ (* fin map2_l *)
+ destruct a0.
+ simpl.
+ destruct (X.compare t0 t1); simpl; f_equal.
+ apply IHm.
+ apply IHm.
+ apply IHm'.
+Qed.
+
+Lemma combine_lelistA : 
+  forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), 
+  lelistA (@ltk elt) (x,e) m -> 
+  lelistA (@ltk elt') (x,e') m' -> 
+  lelistA (@ltk oee') (x,e'') (combine m m').
+Proof.
+ induction m. 
+ intros.
+ simpl.
+ exact (map_lelistA _ _ H0).
+ induction m'. 
+ intros.
+ destruct a.
+ replace (combine ((t0, e0) :: m) nil) with 
+             (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto.
+ exact (map_lelistA _ _ H).
+ intros.
+ simpl.
+ destruct a as (k,e0); destruct a0 as (k',e0').
+ destruct (X.compare k k').
+ inversion_clear H; auto.
+ inversion_clear H; auto.
+ inversion_clear H0; auto.
+Qed.
+Hint Resolve combine_lelistA.
+
+Lemma combine_sorted : 
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), 
+  sort (@ltk oee') (combine m m').
+Proof.
+ induction m. 
+ intros; clear Hm.
+ simpl.
+ apply map_sorted; auto.
+ induction m'. 
+ intros; clear Hm'.
+ destruct a.
+ replace (combine ((t0, e) :: m) nil) with 
+             (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto.
+ apply map_sorted; auto.
+ intros.
+ simpl.
+ destruct a as (k,e); destruct a0 as (k',e').
+ destruct (X.compare k k').
+ inversion_clear Hm.
+ constructor; auto.
+ assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto.
+ exact (combine_lelistA _ H0 H1). 
+ inversion_clear Hm; inversion_clear Hm'.
+ constructor; auto.
+ assert (lelistA (ltk (elt:=elt')) (k, e') m') by apply Inf_eq with (k',e'); auto.
+ exact (combine_lelistA _ H0 H3). 
+ inversion_clear Hm; inversion_clear Hm'.
+ constructor; auto.
+ change (lelistA (ltk (elt:=oee')) (k', (None, Some e'))
+                 (combine ((k,e)::m) m')).
+ assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto.
+ exact (combine_lelistA _  H3 H2).
+Qed.
+
+Lemma map2_sorted : 
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), 
+  sort (@ltk elt'') (map2 m m').
+Proof.
+ intros.
+ rewrite <- map2_alt_equiv.
+ unfold map2_alt.
+ assert (H0:=combine_sorted Hm Hm').
+ set (l0:=combine m m') in *; clearbody l0.
+ set (f':= fun p : oee' => f (fst p) (snd p)).
+ assert (H1:=map_sorted (elt' := option elt'') H0 f').
+ set (l1:=map f' l0) in *; clearbody l1. 
+ clear f' f H0 l0 Hm Hm' m m'.
+ induction l1.
+ simpl; auto.
+ inversion_clear H1.
+ destruct a; destruct o; auto.
+ simpl.
+ constructor; auto.
+ clear IHl1.
+ induction l1.
+ simpl; auto.
+ destruct a; destruct o; simpl; auto.
+ inversion_clear H0; auto.
+ inversion_clear H0.
+ red in H1; simpl in H1.
+ inversion_clear H.
+ apply IHl1; auto.
+ apply Inf_lt with (t1, None (A:=elt'')); auto.
+Qed.
+ 
+Definition at_least_one (o:option elt)(o':option elt') := 
+  match o, o' with 
+   | None, None => None 
+   | _, _  => Some (o,o')
+  end.
+
+Lemma combine_1 : 
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), 
+  find x (combine m m') = at_least_one (find x m) (find x m'). 
+Proof.
+ induction m.
+ intros.
+ simpl.
+ induction m'.
+ intros; simpl; auto.
+ simpl; destruct a.
+ simpl; destruct (X.compare x t0); simpl; auto.
+ inversion_clear Hm'; auto.
+ induction m'.
+ (* m' = nil *)
+ intros; destruct a; simpl.
+ destruct (X.compare x t0); simpl; auto.
+ inversion_clear Hm; clear H0 l Hm' IHm t0.
+ induction m; simpl; auto.
+ inversion_clear H.
+ destruct a.
+ simpl; destruct (X.compare x t0); simpl; auto.
+ (* m' <> nil *)
+ intros.
+ destruct a as (k,e); destruct a0 as (k',e'); simpl.
+ inversion Hm; inversion Hm'; subst.
+ destruct (X.compare k k'); simpl;
+  destruct (X.compare x k); 
+   elim_comp || destruct (X.compare x k'); simpl; auto.
+ rewrite IHm; auto; simpl; elim_comp; auto.
+ rewrite IHm; auto; simpl; elim_comp; auto.
+ rewrite IHm; auto; simpl; elim_comp; auto.
+ change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')).
+ rewrite IHm'; auto. 
+ simpl find; elim_comp; auto.
+ change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')).
+ rewrite IHm'; auto. 
+ simpl find; elim_comp; auto.
+ change (find x (combine ((k, e) :: m) m') = 
+         at_least_one (find x m) (find x m')).
+ rewrite IHm'; auto. 
+ simpl find; elim_comp; auto.
+Qed.
+
+Definition at_least_one_then_f (o:option elt)(o':option elt') := 
+  match o, o' with 
+   | None, None => None 
+   | _, _  => f o o'
+  end.
+
+Lemma map2_0 : 
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), 
+  find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). 
+Proof.
+ intros.
+ rewrite <- map2_alt_equiv.
+ unfold map2_alt.
+ assert (H:=combine_1 Hm Hm' x).
+ assert (H2:=combine_sorted Hm Hm').
+ set (f':= fun p : oee' => f (fst p) (snd p)).
+ set (m0 := combine m m') in *; clearbody m0.
+ set (o:=find x m) in *; clearbody o. 
+ set (o':=find x m') in *; clearbody o'.
+ clear Hm Hm' m m'.
+ generalize H; clear H.
+ match goal with |- ?m=?n -> ?p=?q =>
+   assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end.
+ induction m0; simpl in *; intuition.
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ destruct a as (k,(oo,oo')); simpl in *.
+ inversion_clear H2.
+ destruct (X.compare x k); simpl in *.
+ (* x < k *)
+ destruct (f' (oo,oo')); simpl.
+ elim_comp.
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ destruct (IHm0 H0) as (H2,_); apply H2; auto.
+ rewrite <- H.
+ case_eq (find x m0); intros; auto.
+ assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
+  red; auto.
+ destruct (Sort_Inf_NotIn H0 (Inf_lt H4 H1)).
+ exists p; apply find_2; auto.
+ (* x = k *)
+ assert (at_least_one_then_f o o' = f oo oo').
+  destruct o; destruct o'; simpl in *; inversion_clear H; auto.
+ rewrite H2.
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ elim_comp; auto.
+ destruct (IHm0 H0) as (_,H4); apply H4; auto.
+ case_eq (find x m0); intros; auto.
+ assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))).
+  red; auto.
+ destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)).
+ exists p; apply find_2; auto.
+ (* k < x *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ elim_comp; auto.
+ destruct (IHm0 H0) as (H3,_); apply H3; auto.
+ destruct (IHm0 H0) as (H3,_); apply H3; auto.
+
+ (* None -> None *)
+ destruct a as (k,(oo,oo')).
+ simpl.
+ inversion_clear H2.
+ destruct (X.compare x k).
+ (* x < k *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ elim_comp; auto.
+ destruct (IHm0 H0) as (_,H4); apply H4; auto.
+ case_eq (find x m0); intros; auto.
+ assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
+  red; auto.
+ destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)).
+ exists p; apply find_2; auto.
+ (* x = k *)
+ discriminate.
+ (* k < x *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ elim_comp; auto.
+ destruct (IHm0 H0) as (_,H4); apply H4; auto.
+ destruct (IHm0 H0) as (_,H4); apply H4; auto.
+Qed.
+
+(** Specification of [map2] *)
+
+Lemma map2_1 : 
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key),
+  In x m \/ In x m' -> 
+  find x (map2 m m') = f (find x m) (find x m'). 
+Proof.
+ intros.
+ rewrite map2_0; auto.
+ destruct H as [(e,H)|(e,H)].
+ rewrite (find_1 Hm H).
+ destruct (find x m'); simpl; auto.
+ rewrite (find_1 Hm' H).
+ destruct (find x m); simpl; auto.
+Qed.
+ 
+Lemma map2_2 : 
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), 
+  In x (map2 m m') -> In x m \/ In x m'. 
+Proof.
+ intros.
+ destruct H as (e,H).
+ generalize (map2_0 Hm Hm' x).
+ rewrite (find_1 (map2_sorted Hm Hm') H).
+ generalize (@find_2 _ m x).
+ generalize (@find_2 _ m' x).
+ destruct (find x m); 
+   destruct (find x m'); simpl; intros.
+ left; exists e0; auto. 
+ left; exists e0; auto.
+ right; exists e0; auto.
+ discriminate.
+Qed.
+
+End Elt3.
+End Raw.
+
+Module Make (X: OrderedType) <: S with Module E := X.
+Module Raw := Raw X. 
+Module E := X.
+
+Definition key := X.t.
+
+Record slist (elt:Set) : Set :=  
+  {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}.
+Definition t (elt:Set) := slist elt. 
+
+Section Elt. 
+ Variable elt elt' elt'':Set. 
+
+ Implicit Types m : t elt.
+
+ Definition empty := Build_slist (Raw.empty_sorted elt).
+ Definition is_empty m := Raw.is_empty m.(this).
+ Definition add x e m := Build_slist (Raw.add_sorted m.(sorted) x e).
+ Definition find x m := Raw.find x m.(this).
+ Definition remove x m := Build_slist (Raw.remove_sorted m.(sorted) x). 
+ Definition mem x m := Raw.mem x m.(this).
+ Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f).
+ Definition mapi f m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f).
+ Definition map2 f m (m':t elt') : t elt'' := 
+ Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)).
+ Definition elements m := @Raw.elements elt m.(this).
+ Definition fold A f m i := @Raw.fold elt A f m.(this) i.
+ Definition equal cmp m m' := @Raw.equal elt cmp m.(this) m'.(this).
+
+ Definition MapsTo x e m := Raw.PX.MapsTo x e m.(this).
+ Definition In x m := Raw.PX.In x m.(this).
+ Definition Empty m := Raw.Empty m.(this).
+ Definition Equal cmp m m' := @Raw.Equal elt cmp m.(this) m'.(this).
+
+ Definition eq_key := Raw.PX.eqk.
+ Definition eq_key_elt := Raw.PX.eqke.
+ Definition lt_key := Raw.PX.ltk.
+
+ Definition MapsTo_1 m := @Raw.PX.MapsTo_eq elt m.(this).
+
+ Definition mem_1 m := @Raw.mem_1 elt m.(this) m.(sorted).
+ Definition mem_2 m := @Raw.mem_2 elt m.(this) m.(sorted).
+
+ Definition empty_1 := @Raw.empty_1.
+
+ Definition is_empty_1 m := @Raw.is_empty_1 elt m.(this).
+ Definition is_empty_2 m := @Raw.is_empty_2 elt m.(this).
+
+ Definition add_1 m := @Raw.add_1 elt m.(this).
+ Definition add_2 m := @Raw.add_2 elt m.(this).
+ Definition add_3 m := @Raw.add_3 elt m.(this).
+
+ Definition remove_1 m := @Raw.remove_1 elt m.(this) m.(sorted).
+ Definition remove_2 m := @Raw.remove_2 elt m.(this) m.(sorted).
+ Definition remove_3 m := @Raw.remove_3 elt m.(this) m.(sorted).
+
+ Definition find_1 m := @Raw.find_1 elt m.(this) m.(sorted).
+ Definition find_2 m := @Raw.find_2 elt m.(this).
+
+ Definition elements_1 m := @Raw.elements_1 elt m.(this). 
+ Definition elements_2 m := @Raw.elements_2 elt m.(this). 
+ Definition elements_3 m := @Raw.elements_3 elt m.(this) m.(sorted). 
+
+ Definition fold_1 m := @Raw.fold_1 elt m.(this).
+
+ Definition map_1 m := @Raw.map_1 elt elt' m.(this).
+ Definition map_2 m := @Raw.map_2 elt elt' m.(this).
+
+ Definition mapi_1 m := @Raw.mapi_1 elt elt' m.(this).
+ Definition mapi_2 m := @Raw.mapi_2 elt elt' m.(this).
+
+ Definition map2_1 m (m':t elt') x f := 
+  @Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x.
+ Definition map2_2 m (m':t elt') x f := 
+  @Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x.
+
+ Definition equal_1 m m' := 
+  @Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted).
+ Definition equal_2 m m' := 
+  @Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted).
+
+ End Elt.
+End Make.
+
+Module Make_ord (X: OrderedType)(D : OrderedType) <: 
+Sord with Module Data := D 
+        with Module MapS.E := X.
+
+Module Data := D.
+Module MapS := Make(X). 
+Import MapS.
+
+Module MD := OrderedTypeFacts(D).
+Import MD.
+
+Definition t := MapS.t D.t. 
+
+Definition cmp e e' := match D.compare e e' with Eq _ => true | _ => false end.
+
+Fixpoint eq_list (m m' : list (X.t * D.t)) { struct m } : Prop := 
+  match m, m' with 
+   | nil, nil => True
+   | (x,e)::l, (x',e')::l' => 
+      match X.compare x x' with 
+       | Eq _ => D.eq e e' /\ eq_list l l'
+       | _       => False
+      end 
+   | _, _ => False
+  end.
+
+Definition eq m m' := eq_list m.(this) m'.(this).
+
+Fixpoint lt_list (m m' : list (X.t * D.t)) {struct m} : Prop := 
+  match m, m' with 
+   | nil, nil => False
+   | nil, _  => True
+   | _, nil  => False
+   | (x,e)::l, (x',e')::l' => 
+      match X.compare x x' with 
+       | Lt _ => True
+       | Gt _ => False
+       | Eq _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l')
+      end
+  end.
+
+Definition lt m m' := lt_list m.(this) m'.(this).
+
+Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true.
+Proof.
+ intros (l,Hl); induction l.
+ intros (l',Hl'); unfold eq; simpl.
+ destruct l'; unfold equal; simpl; intuition.
+ intros (l',Hl'); unfold eq.
+ destruct l'.
+ destruct a; unfold equal; simpl; intuition.
+ destruct a as (x,e).
+ destruct p as (x',e').
+ unfold equal; simpl. 
+ destruct (X.compare x x'); simpl; intuition.
+ unfold cmp at 1. 
+ MD.elim_comp; clear H; simpl.
+ inversion_clear Hl.
+ inversion_clear Hl'.
+ destruct (IHl H (Build_slist H3)).
+ unfold equal, eq in H5; simpl in H5; auto.
+ destruct (andb_prop _ _ H); clear H.
+ generalize H0; unfold cmp.
+ MD.elim_comp; auto; intro; discriminate.
+ destruct (andb_prop _ _ H); clear H.
+ inversion_clear Hl.
+ inversion_clear Hl'.
+ destruct (IHl H (Build_slist H3)).
+ unfold equal, eq in H6; simpl in H6; auto.
+Qed.
+
+Lemma eq_1 : forall m m', Equal cmp m m' -> eq m m'.
+Proof.
+ intros.
+ generalize (@equal_1 D.t m m' cmp).
+ generalize (@eq_equal m m').
+ intuition.
+Qed.
+
+Lemma eq_2 : forall m m', eq m m' -> Equal cmp m m'.
+Proof.
+ intros.
+ generalize (@equal_2 D.t m m' cmp).
+ generalize (@eq_equal m m').
+ intuition.
+Qed.
+
+Lemma eq_refl : forall m : t, eq m m.
+Proof.
+ intros (m,Hm); induction m; unfold eq; simpl; auto.
+ destruct a.
+ destruct (X.compare t0 t0); auto.
+ apply (MapS.Raw.MX.lt_antirefl l); auto.
+ split.
+ apply D.eq_refl.
+ inversion_clear Hm.
+ apply (IHm H).
+ apply (MapS.Raw.MX.lt_antirefl l); auto.
+Qed.
+
+Lemma  eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+Proof.
+ intros (m,Hm); induction m; 
+ intros (m', Hm'); destruct m'; unfold eq; simpl;
+ try destruct a as (x,e); try destruct p as (x',e'); auto.
+ destruct (X.compare x x'); MapS.Raw.MX.elim_comp; intuition.
+ inversion_clear Hm; inversion_clear Hm'.
+ apply (IHm H0 (Build_slist H4)); auto.
+Qed.
+
+Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
+Proof. 
+ intros (m1,Hm1); induction m1; 
+ intros (m2, Hm2); destruct m2; 
+ intros (m3, Hm3); destruct m3; unfold eq; simpl; 
+ try destruct a as (x,e); 
+ try destruct p as (x',e'); 
+ try destruct p0 as (x'',e''); try contradiction; auto.
+ destruct (X.compare x x'); 
+  destruct (X.compare x' x''); 
+   MapS.Raw.MX.elim_comp.
+ intuition.
+ apply D.eq_trans with e'; auto.
+ inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
+ apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition.
+Qed.
+
+Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
+Proof.
+ intros (m1,Hm1); induction m1; 
+ intros (m2, Hm2); destruct m2; 
+ intros (m3, Hm3); destruct m3; unfold lt; simpl; 
+ try destruct a as (x,e); 
+ try destruct p as (x',e'); 
+ try destruct p0 as (x'',e''); try contradiction; auto.
+ destruct (X.compare x x'); 
+  destruct (X.compare x' x''); 
+   MapS.Raw.MX.elim_comp; auto.
+ intuition.
+ left; apply D.lt_trans with e'; auto.
+ left; apply lt_eq with e'; auto.
+ left; apply eq_lt with e'; auto.
+ right.
+ split.
+ apply D.eq_trans with e'; auto.
+ inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
+ apply (IHm1 H2 (Build_slist H6) (Build_slist H8)); intuition.
+Qed.
+
+Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
+Proof.
+ intros (m1,Hm1); induction m1; 
+ intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; 
+ try destruct a as (x,e); 
+ try destruct p as (x',e'); try contradiction; auto.
+ destruct (X.compare x x'); auto.
+ intuition.
+ exact (D.lt_not_eq H0 H1).
+ inversion_clear Hm1; inversion_clear Hm2.
+ apply (IHm1 H0 (Build_slist H5)); intuition.
+Qed.
+
+Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto.
+
+Definition compare : forall m1 m2, Compare lt eq m1 m2.
+Proof.
+ intros (m1,Hm1); induction m1; 
+ intros (m2, Hm2); destruct m2; 
+  [ apply Eq | apply Lt | apply Gt | ]; cmp_solve.
+ destruct a as (x,e); destruct p as (x',e'). 
+ destruct (X.compare x x'); 
+  [ apply Lt | | apply Gt ]; cmp_solve.
+ destruct (D.compare e e'); 
+  [ apply Lt | | apply Gt ]; cmp_solve.
+ assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1).
+  inversion_clear Hm1; auto.
+ assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2).
+  inversion_clear Hm2; auto.
+ destruct (IHm1 Hm11 (Build_slist Hm22)); 
+  [ apply Lt | apply Eq | apply Gt ]; cmp_solve.
+Qed.
+
+End Make_ord. 
diff --git a/theories/FSets/FMapWeak.v b/theories/FSets/FMapWeak.v
new file mode 100644
index 000000000..9e377d1d0
--- /dev/null
+++ b/theories/FSets/FMapWeak.v
@@ -0,0 +1,12 @@
+(***********************************************************************)
+(*  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: FSet.v,v 1.2 2004/12/08 19:19:24 letouzey Exp $ *)
+
+Require Export FMapWeakInterface.
+Require Export FMapWeakList.
diff --git a/theories/FSets/FMapWeakInterface.v b/theories/FSets/FMapWeakInterface.v
new file mode 100644
index 000000000..22ff07c1f
--- /dev/null
+++ b/theories/FSets/FMapWeakInterface.v
@@ -0,0 +1,201 @@
+(***********************************************************************)
+(*  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,v 1.4 2006/02/27 15:39:43 letouzey Exp $ *)
+
+(** * 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 : noredunA 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
new file mode 100644
index 000000000..6c544053e
--- /dev/null
+++ b/theories/FSets/FMapWeakList.v
@@ -0,0 +1,960 @@
+(***********************************************************************)
+(*  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: FSet.v,v 1.2 2004/12/08 19:19:24 letouzey Exp $ *)
+
+(** * Finite map library *)  
+
+(** This file proposes an implementation of the non-dependant interface
+ [FMapInterface.S] using lists of pairs,  unordered but without redundancy. *)
+
+Require Import FSetInterface. 
+Require Import FSetWeakInterface.
+Require Import FMapWeakInterface.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Arguments Scope list [type_scope].
+
+Module Raw (X:DecidableType).
+
+Module PX := PairDecidableType X.
+Import PX.
+
+Definition key := X.t.
+Definition t (elt:Set) := list (X.t * elt).
+
+Section Elt.
+
+Variable elt : Set.
+
+(* now in PairDecidableType:
+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').
+*)
+
+Notation eqk := (eqk (elt:=elt)).   
+Notation eqke := (eqke (elt:=elt)).
+Notation MapsTo := (MapsTo (elt:=elt)).
+Notation In := (In (elt:=elt)).
+Notation noredunA := (noredunA eqk).
+
+(** * [empty] *)
+
+Definition empty : t elt := nil.
+
+Definition Empty m := forall (a : key)(e:elt), ~ MapsTo a e m.
+
+Lemma empty_1 : Empty empty.
+Proof.
+ unfold Empty,empty.
+ intros a e.
+ intro abs.
+ inversion abs.
+Qed.
+
+Hint Resolve empty_1.
+
+Lemma empty_noredun : noredunA empty.
+Proof. 
+ unfold empty; auto.
+Qed.
+
+(** * [is_empty] *)
+
+Definition is_empty (l : t elt) : bool := if l then true else false.
+
+Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. 
+Proof.
+ unfold Empty, PX.MapsTo.
+ intros m.
+ case m;auto.
+ intros p l inlist.
+ destruct p.
+ absurd (InA eqke (t0, e) ((t0, e) :: l));auto.
+Qed.
+
+Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+Proof.
+ intros m.
+ case m;auto.
+ intros p l abs.
+ inversion abs.
+Qed.
+
+(** * [mem] *)
+
+Fixpoint mem (k : key) (s : t elt) {struct s} : bool :=
+  match s with
+   | nil => false
+   | (k',_) :: l => if X.eq_dec k k' then true else mem k l
+  end.
+
+Lemma mem_1 : forall m (Hm:noredunA m) x, In x m -> mem x m = true.
+Proof.
+ intros m Hm x; generalize Hm; clear Hm.      
+ functional induction mem x m;intros noredun belong1;trivial.
+ inversion belong1. inversion H.
+ inversion_clear noredun.
+ inversion_clear belong1.
+ inversion_clear H3.
+ compute in H4; destruct H4.
+ elim H; auto.
+ apply H0; auto.
+ exists x; auto.
+Qed. 
+
+Lemma mem_2 : forall m (Hm:noredunA m) x, mem x m = true -> In x m. 
+Proof.
+ intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo.
+ functional induction mem x m; intros noredun hyp; try discriminate.
+ exists e; auto. 
+ inversion_clear noredun.
+ destruct H0; auto.
+ exists x; auto.
+Qed.
+
+(** * [find] *)
+
+Fixpoint find (k:key) (s: t elt) {struct s} : option elt :=
+  match s with
+   | nil => None
+   | (k',x)::s' => if X.eq_dec k k' then Some x else find k s'
+  end.
+
+Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+Proof.
+ intros m x. unfold PX.MapsTo.
+ functional induction find x m;simpl;intros e' eqfind; inversion eqfind; auto.
+Qed.
+
+Lemma find_1 : forall m (Hm:noredunA m) x e, 
+  MapsTo x e m -> find x m = Some e. 
+Proof.
+ intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction find x m;simpl; subst; try clear H_eq_1.
+
+ inversion 2.
+
+ do 2 inversion_clear 1.
+ compute in H3; destruct H3; subst; trivial.
+ elim H0; apply InA_eqk with (k,e); auto.
+
+ do 2 inversion_clear 1; auto.
+ compute in H4; destruct H4; elim H; auto.
+Qed.
+
+(* Not part of the exported specifications, used later for [combine]. *)
+
+Lemma find_eq : forall m (Hm:noredunA m) x x', 
+   X.eq x x' -> find x m = find x' m.
+Proof.
+ induction m; simpl; auto; destruct a; intros.
+ inversion_clear Hm.
+ rewrite (IHm H1 x x'); auto.
+ destruct (X.eq_dec x t0); destruct (X.eq_dec x' t0); trivial.
+ elim n; apply X.eq_trans with x; auto.
+ elim n; apply X.eq_trans with x'; auto.
+Qed.
+
+(** * [add] *)
+
+Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
+  match s with
+   | nil => (k,x) :: nil
+   | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l
+  end.
+
+Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m).
+Proof.
+ intros m x y e; generalize y; clear y; unfold PX.MapsTo.
+ functional induction add x e m;simpl;auto.
+Qed.
+
+Lemma add_2 : forall m x y e e', 
+  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+Proof.
+ intros m x  y e e'; generalize y e; clear y e; unfold PX.MapsTo.
+ functional induction add x e' m;simpl;auto.
+ intros y' e' eqky';  inversion_clear 1.
+ destruct H1; simpl in *.
+ elim eqky'; apply X.eq_trans with k'; auto.
+ auto.
+ intros y' e' eqky'; inversion_clear 1; intuition.
+Qed.
+  
+Lemma add_3 : forall m x y e e',
+  ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+Proof.
+ intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo.
+ functional induction add x e' m;simpl;auto.
+ intros; apply (In_inv_3 H0); auto.
+ constructor 2; apply (In_inv_3 H1); auto.
+ inversion_clear 2; auto.
+Qed.
+
+Lemma add_3' : forall m x y e e', 
+  ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. 
+Proof.
+ intros m x y e e'. generalize y e; clear y e.
+ functional induction add x e' m;simpl;auto.
+ inversion_clear 2.
+ compute in H1; elim H; auto.
+ inversion H1. 
+ constructor 2; inversion_clear H1; auto.
+ compute in H2; elim H0; auto.
+ inversion_clear 2; auto.
+Qed.
+
+Lemma add_noredun : forall m (Hm:noredunA m) x e, noredunA (add x e m).
+Proof.
+ induction m.
+ simpl; constructor; auto; red; inversion 1.
+ intros.
+ destruct a as (x',e').
+ simpl; case (X.eq_dec x x'); inversion_clear Hm; auto.
+ constructor; auto.
+ swap H.
+ apply InA_eqk with (x,e); auto.
+ constructor; auto.
+ swap H; apply add_3' with x e; auto.
+Qed.
+
+(* Not part of the exported specifications, used later for [combine]. *)
+
+Lemma add_eq : forall m (Hm:noredunA m) x a e, 
+   X.eq x a -> find x (add a e m) = Some e.
+Proof.
+ intros.
+ apply find_1; auto.
+ apply add_noredun; auto.
+ apply add_1; auto.
+Qed.
+
+Lemma add_not_eq : forall m (Hm:noredunA m) x a e, 
+  ~X.eq x a -> find x (add a e m) = find x m.
+Proof.
+ intros.
+ case_eq (find x m); intros.
+ apply find_1; auto.
+ apply add_noredun; auto.
+ apply add_2; auto.
+ apply find_2; auto.
+ case_eq (find x (add a e m)); intros; auto.
+ rewrite <- H0; symmetry.
+ apply find_1; auto.
+ apply add_3 with a e; auto.
+ apply find_2; auto.
+Qed.
+
+
+(** * [remove] *)
+
+Fixpoint remove (k : key) (s : t elt) {struct s} : t elt :=
+  match s with
+   | nil => nil
+   | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l
+  end.  
+
+Lemma remove_1 : forall m (Hm:noredunA m) x y, X.eq x y -> ~ In y (remove x m).
+Proof.
+ intros m Hm x y; generalize Hm; clear Hm.
+ functional induction remove x m;simpl;intros;auto.
+
+ red; inversion 1; inversion H1.
+
+ inversion_clear Hm.
+ subst.
+ swap H1.
+ destruct H3 as (e,H3); unfold PX.MapsTo in H3.
+ apply InA_eqk with (y,e); auto.
+ compute; apply X.eq_trans with k; auto.
+  
+ intro H2.
+ destruct H2 as (e,H2); inversion_clear H2.
+ compute in H3; destruct H3.
+ elim H; apply X.eq_trans with y; auto.
+ inversion_clear Hm.
+ elim (H0 H4 H1).
+ exists e; auto.
+Qed.
+  
+Lemma remove_2 : forall m (Hm:noredunA m) x y e, 
+  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction remove x m;auto.
+ inversion_clear 3; auto.
+ compute in H2; destruct H2.
+ elim H0; apply X.eq_trans with k'; auto.
+  
+ inversion_clear 1; inversion_clear 2; auto.
+Qed.
+
+Lemma remove_3 : forall m (Hm:noredunA m) x y e, 
+  MapsTo y e (remove x m) -> MapsTo y e m.
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction remove x m;auto.
+ do 2 inversion_clear 1; auto.
+Qed.
+
+Lemma remove_3' : forall m (Hm:noredunA m) x y e, 
+  InA eqk (y,e) (remove x m) -> InA eqk (y,e) m.
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction remove x m;auto.
+ do 2 inversion_clear 1; auto.
+Qed.
+
+Lemma remove_noredun : forall m (Hm:noredunA m) x, noredunA (remove x m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ inversion_clear Hm.
+ destruct a as (x',e').
+ simpl; case (X.eq_dec x x'); auto.
+ constructor; auto.
+ swap H; apply remove_3' with x; auto.
+Qed.  
+
+(** * [elements] *)
+
+Definition elements (m: t elt) := m.
+
+Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m).
+Proof.
+ auto.
+Qed.
+
+Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m.
+Proof. 
+auto.
+Qed.
+
+Lemma elements_3 : forall m (Hm:noredunA m), noredunA (elements m). 
+Proof. 
+ auto.
+Qed.
+
+(** * [fold] *)
+
+Fixpoint fold (A:Set)(f:key->elt->A->A)(m:t elt) {struct m} : A -> A :=
+  fun acc => 
+  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),
+  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.
+Qed.
+
+(** * [equal] *)
+
+Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := 
+  match find k m' with 
+   | None => false
+   | Some e' => cmp e e'
+  end.
+
+Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := 
+  fold (fun k e b => andb (check cmp k e m') b) m true. 
+   
+Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool :=
+  andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m).
+
+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' := 
+  (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 submap_1 : forall m (Hm:noredunA m) m' (Hm': noredunA m') cmp, 
+  Submap cmp m m' -> submap cmp m m' = true. 
+Proof.
+ unfold Submap, submap.
+ induction m.
+ simpl; auto.
+ destruct a; simpl; intros.
+ destruct H.
+ inversion_clear Hm.
+ assert (H3 : In t0 m').
+  apply H; exists e; auto.
+ destruct H3 as (e', H3).
+ unfold check at 2; rewrite (find_1 Hm' H3).
+ rewrite (H0 t0); simpl; auto.
+ eapply IHm; auto.
+ split; intuition.
+ apply H.
+ destruct H5 as (e'',H5); exists e''; auto.
+ apply H0 with k; auto.
+Qed.
+   
+Lemma submap_2 : forall m (Hm:noredunA m) m' (Hm': noredunA m') cmp, 
+  submap cmp m m' = true -> Submap cmp m m'. 
+Proof.
+ unfold Submap, submap.
+ induction m.
+ simpl; auto.
+ intuition.
+ destruct H0; inversion H0.
+ inversion H0.
+ 
+ destruct a; simpl; intros.
+ inversion_clear Hm.
+ rewrite andb_b_true in H.
+ assert (check cmp t0 e m' = true).
+  clear H1 H0 Hm' IHm.
+  set (b:=check cmp t0 e m') in *.
+  generalize H; clear H; generalize b; clear b.
+  induction m; simpl; auto; intros.
+  destruct a; simpl in *.
+  destruct (andb_prop _ _ (IHm _ H)); auto.
+ rewrite H2 in H.
+ destruct (IHm H1 m' Hm' cmp H); auto.
+ unfold check in H2.
+ case_eq (find t0 m'); [intros e' H5 | intros H5]; 
+  rewrite H5 in H2; try discriminate.
+ split; intros.
+ destruct H6 as (e0,H6); inversion_clear H6.
+ compute in H7; destruct H7; subst.
+ exists e'.
+ apply PX.MapsTo_eq with t0; auto.
+ apply find_2; auto.
+ apply H3.
+ exists e0; auto.
+ inversion_clear H6.
+ compute in H8; destruct H8; subst.
+ rewrite (find_1 Hm' (PX.MapsTo_eq H6 H7)) in H5; congruence.
+ apply H4 with k; auto.
+Qed.
+
+(** Specification of [equal] *)
+
+Lemma equal_1 : forall m (Hm:noredunA m) m' (Hm': noredunA m') cmp, 
+  Equal cmp m m' -> equal cmp m m' = true. 
+Proof. 
+ unfold Equal, equal.
+ intuition.
+ apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder.
+Qed.
+
+Lemma equal_2 : forall m (Hm:noredunA m) m' (Hm':noredunA m') cmp, 
+  equal cmp m m' = true -> Equal cmp m m'.
+Proof.
+ unfold Equal, equal.
+ intros.
+ destruct (andb_prop _ _ H); clear H.
+ generalize (submap_2 Hm Hm' H0).
+ generalize (submap_2 Hm' Hm H1).
+ firstorder.
+Qed. 
+
+Variable elt':Set.
+
+(** * [map] and [mapi] *)
+  
+Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' :=
+  match m with
+   | nil => nil
+   | (k,e)::m' => (k,f e) :: map f m'
+  end.
+
+Fixpoint mapi (f: key -> elt -> elt') (m:t elt) {struct m} : t elt' :=
+  match m with
+   | nil => nil
+   | (k,e)::m' => (k,f k e) :: mapi f m'
+  end.
+
+End Elt.
+Section Elt2. 
+(* A new section is necessary for previous definitions to work 
+   with different [elt], especially [MapsTo]... *)
+  
+Variable elt elt' : Set.
+
+(** Specification of [map] *)
+
+Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), 
+  MapsTo x e m -> MapsTo x (f e) (map f m).
+Proof.
+ intros m x e f.
+ (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
+ induction m.
+ inversion 1.
+    
+ destruct a as (x',e').
+ simpl. 
+ inversion_clear 1.
+ constructor 1.
+ unfold eqke in *; simpl in *; intuition congruence.
+ constructor 2.
+ unfold MapsTo in *; auto.
+Qed.
+
+Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), 
+  In x (map f m) -> In x m.
+Proof.
+ intros m x f. 
+ (* functional induction map elt elt' f m. *) (* Marche pas ??? *)
+ induction m; simpl.
+ intros (e,abs).
+ inversion abs.
+    
+ destruct a as (x',e).
+ intros hyp.
+ inversion hyp. clear hyp.
+ inversion H; subst; rename x0 into e'.
+ exists e; constructor.
+ unfold eqke in *; simpl in *; intuition.
+ destruct IHm as (e'',hyp).
+ exists e'; auto.
+ exists e''.
+ constructor 2; auto.
+Qed.
+
+Lemma map_noredun : forall m (Hm : noredunA (@eqk elt) m)(f:elt->elt'), 
+  noredunA (@eqk elt') (map f m).
+Proof.   
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm.
+ constructor; auto.
+ swap 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.
+Qed.      
+ 
+(** Specification of [mapi] *)
+
+Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), 
+  MapsTo x e m -> 
+  exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
+Proof.
+ intros m x e f.
+ (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
+ induction m.
+ inversion 1.
+    
+ destruct a as (x',e').
+ simpl. 
+ inversion_clear 1.
+ exists x'.
+ destruct H0; simpl in *.
+ split; auto.
+ constructor 1.
+ unfold eqke in *; simpl in *; intuition congruence.
+ destruct IHm as (y, hyp); auto.
+ exists y; intuition.
+Qed.  
+
+Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), 
+  In x (mapi f m) -> In x m.
+Proof.
+ intros m x f. 
+ (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
+ induction m; simpl.
+ intros (e,abs).
+ inversion abs.
+    
+ destruct a as (x',e).
+ intros hyp.
+ inversion hyp. clear hyp.
+ inversion H; subst; rename x0 into e'.
+ exists e; constructor.
+ unfold eqke in *; simpl in *; intuition.
+ destruct IHm as (e'',hyp).
+ exists e'; auto.
+ exists e''.
+ constructor 2; auto.
+Qed.
+
+Lemma mapi_noredun : forall m (Hm : noredunA (@eqk elt) m)(f: key->elt->elt'), 
+  noredunA (@eqk elt') (mapi f m).
+Proof.
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm; auto.
+ constructor; auto.
+ swap H.
+ clear IHm H0.
+ induction m; simpl in *; auto.
+ inversion_clear H1.
+ destruct a; inversion_clear H1; auto.
+Qed.
+
+End Elt2. 
+Section Elt3.
+
+Variable elt elt' elt'' : Set.
+
+Notation oee' := (option elt * option elt')%type.
+	
+Definition combine_l (m:t elt)(m':t elt') : t oee' :=
+  mapi (fun k e => (Some e, find k m')) m.	
+
+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) := 
+  List.fold_right (fun p => f (fst p) (snd p)) i l.
+
+Definition combine (m:t elt)(m':t elt') : t oee' := 
+  let l := combine_l m m' in 
+  let r := combine_r m m' in 
+  fold_right_pair (add (elt:=oee')) l r.
+
+Lemma fold_right_pair_noredun : 
+  forall l r (Hl: noredunA (eqk (elt:=oee')) l) 
+    (Hl: noredunA (eqk (elt:=oee')) r), 
+    noredunA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) l r).
+Proof.
+ induction l; simpl; auto.
+ destruct a; simpl; auto.
+ inversion_clear 1.
+ intros; apply add_noredun; auto.
+Qed.
+Hint Resolve fold_right_pair_noredun.
+
+Lemma combine_noredun : 
+  forall m (Hm:noredunA (@eqk elt) m) m' (Hm':noredunA (@eqk elt') m'), 
+  noredunA (@eqk oee') (combine m m').
+Proof.
+ unfold combine, combine_r, combine_l.
+ intros.
+ set (f1 := fun (k : key) (e : elt) => (Some e, find k m')).
+ set (f2 := fun (k : key) (e' : elt') => (find k m, Some e')).
+ generalize (mapi_noredun Hm f1).
+ generalize (mapi_noredun Hm' f2).
+ set (l := mapi f1 m); clearbody l.
+ set (r := mapi f2 m'); clearbody r.
+ auto.
+Qed.
+
+Definition at_least_left (o:option elt)(o':option elt') := 
+  match o with 
+   | None => None 
+   | _  => Some (o,o')
+  end.
+
+Definition at_least_right (o:option elt)(o':option elt') := 
+  match o' with 
+   | None => None 
+   | _  => Some (o,o')
+  end.
+
+Lemma combine_l_1 : 
+  forall m (Hm:noredunA (@eqk elt) m) m' (Hm':noredunA (@eqk elt') m')(x:key), 
+  find x (combine_l m m') = at_least_left (find x m) (find x m'). 
+Proof.
+ unfold combine_l.
+ intros.
+ case_eq (find x m); intros.
+ simpl.
+ apply find_1.
+ apply mapi_noredun; auto.
+ destruct (mapi_1 (fun k e => (Some e, find k m')) (find_2 H)) as (y,(H0,H1)).
+ rewrite (find_eq Hm' (X.eq_sym H0)); auto.
+ simpl.
+ case_eq (find x (mapi (fun k e => (Some e, find k m')) m)); intros; auto.
+ destruct (@mapi_2 _ _ m x (fun k e => (Some e, find k m'))).
+ exists p; apply find_2; auto.
+ rewrite (find_1 Hm H1) in H; discriminate.
+Qed.
+
+Lemma combine_r_1 : 
+  forall m (Hm:noredunA (@eqk elt) m) m' (Hm':noredunA (@eqk elt') m')(x:key), 
+  find x (combine_r m m') = at_least_right (find x m) (find x m'). 
+Proof.
+ unfold combine_r.
+ intros.
+ case_eq (find x m'); intros.
+ simpl.
+ apply find_1.
+ apply mapi_noredun; auto.
+ destruct (mapi_1 (fun k e => (find k m, Some e)) (find_2 H)) as (y,(H0,H1)).
+ rewrite (find_eq Hm (X.eq_sym H0)); auto.
+ simpl.
+ case_eq (find x (mapi (fun k e' => (find k m, Some e')) m')); intros; auto.
+ destruct (@mapi_2 _ _ m' x (fun k e' => (find k m, Some e'))).
+ exists p; apply find_2; auto.
+ rewrite (find_1 Hm' H1) in H; discriminate.
+Qed.
+
+Definition at_least_one (o:option elt)(o':option elt') := 
+  match o, o' with 
+   | None, None => None 
+   | _, _  => Some (o,o')
+  end.
+
+Lemma combine_1 : 
+  forall m (Hm:noredunA (@eqk elt) m) m' (Hm':noredunA (@eqk elt') m')(x:key), 
+  find x (combine m m') = at_least_one (find x m) (find x m'). 
+Proof.
+ unfold combine.
+ intros.
+ generalize (combine_r_1 Hm Hm' x).
+ generalize (combine_l_1 Hm Hm' x).
+ assert (noredunA (eqk (elt:=oee')) (combine_l m m')).
+  unfold combine_l; apply mapi_noredun; auto.
+ assert (noredunA (eqk (elt:=oee')) (combine_r m m')).
+  unfold combine_r; apply mapi_noredun; auto.
+ set (l := combine_l m m') in *; clearbody l.
+ set (r := combine_r m m') in *; clearbody r.
+ set (o := find x m); clearbody o.
+ set (o' := find x m'); clearbody o'.
+ clear Hm' Hm m m'.
+ induction l.
+ destruct o; destruct o'; simpl; intros; discriminate || auto.
+ destruct a; simpl in *; intros.
+ destruct (X.eq_dec x t0); simpl in *.
+ unfold at_least_left in H1.
+ destruct o; simpl in *; try discriminate.
+ inversion H1; subst.
+ apply add_eq; auto.
+ inversion_clear H; auto.
+ inversion_clear H.
+ rewrite <- IHl; auto.
+ apply add_not_eq; auto.
+Qed.
+
+Variable f : option elt -> option elt' -> option elt''.
+
+Definition option_cons (A:Set)(k:key)(o:option A)(l:list (key*A)) := 
+  match o with
+   | Some e => (k,e)::l
+   | None => l
+  end.
+
+Definition map2 m m' := 
+  let m0 : t oee' := combine m m' in 
+  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in 
+  fold_right_pair (option_cons (A:=elt'')) m1 nil.
+
+Lemma map2_noredun : 
+  forall m (Hm:noredunA (@eqk elt) m) m' (Hm':noredunA (@eqk elt') m'), 
+  noredunA (@eqk elt'') (map2 m m').
+Proof.
+ intros.
+ unfold map2.
+ assert (H0:=combine_noredun Hm Hm').
+ set (l0:=combine m m') in *; clearbody l0.
+ set (f':= fun p : oee' => f (fst p) (snd p)).
+ assert (H1:=map_noredun (elt' := option elt'') H0 f').
+ set (l1:=map f' l0) in *; clearbody l1. 
+ clear f' f H0 l0 Hm Hm' m m'.
+ induction l1.
+ simpl; auto.
+ inversion_clear H1.
+ destruct a; destruct o; simpl; auto.
+ constructor; auto.
+ swap H.
+ clear IHl1.
+ induction l1.
+ inversion H1.
+ inversion_clear H0.
+ destruct a; destruct o; simpl in *; auto.
+ inversion_clear  H1; auto.
+Qed.
+
+Definition at_least_one_then_f (o:option elt)(o':option elt') := 
+  match o, o' with 
+   | None, None => None 
+   | _, _  => f o o'
+  end.
+
+Lemma map2_0 : 
+  forall m (Hm:noredunA (@eqk elt) m) m' (Hm':noredunA (@eqk elt') m')(x:key), 
+  find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). 
+Proof.
+ intros.
+ unfold map2.
+ assert (H:=combine_1 Hm Hm' x).
+ assert (H2:=combine_noredun Hm Hm').
+ set (f':= fun p : oee' => f (fst p) (snd p)).
+ set (m0 := combine m m') in *; clearbody m0.
+ set (o:=find x m) in *; clearbody o. 
+ set (o':=find x m') in *; clearbody o'.
+ clear Hm Hm' m m'.
+ generalize H; clear H.
+ match goal with |- ?m=?n -> ?p=?q =>
+   assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end.
+ induction m0; simpl in *; intuition.
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ destruct a as (k,(oo,oo')); simpl in *.
+ inversion_clear H2.
+ destruct (X.eq_dec x k); simpl in *.
+ (* x = k *)
+ assert (at_least_one_then_f o o' = f oo oo').
+  destruct o; destruct o'; simpl in *; inversion_clear H; auto.
+ rewrite H2.
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl. 
+ destruct (X.eq_dec x k); try absurd_hyp n; auto.
+ destruct (IHm0 H1) as (_,H4); apply H4; auto.
+ case_eq (find x m0); intros; auto.
+ elim H0.
+ apply InA_eqk with (x,p); auto.
+ apply InA_eqke_eqk.
+ exact (find_2 H3). 
+ (* k < x *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ destruct (X.eq_dec x k); [ absurd_hyp n; auto | auto].
+ destruct (IHm0 H1) as (H3,_); apply H3; auto.
+ destruct (IHm0 H1) as (H3,_); apply H3; auto.
+
+ (* None -> None *)
+ destruct a as (k,(oo,oo')).
+ simpl.
+ inversion_clear H2.
+ destruct (X.eq_dec x k).
+ (* x = k *)
+ discriminate.
+ (* k < x *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ destruct (X.eq_dec x k); [ absurd_hyp n; auto | auto].
+ destruct (IHm0 H1) as (_,H4); apply H4; auto.
+ destruct (IHm0 H1) as (_,H4); apply H4; auto.
+Qed.
+
+(** Specification of [map2] *)
+Lemma map2_1 : 
+  forall m (Hm:noredunA (@eqk elt) m) m' (Hm':noredunA (@eqk elt') m')(x:key),
+  In x m \/ In x m' -> 
+  find x (map2 m m') = f (find x m) (find x m'). 
+Proof.
+ intros.
+ rewrite map2_0; auto.
+ destruct H as [(e,H)|(e,H)].
+ rewrite (find_1 Hm H).
+ destruct (find x m'); simpl; auto.
+ rewrite (find_1 Hm' H).
+ destruct (find x m); simpl; auto.
+Qed.
+ 
+Lemma map2_2 : 
+  forall m (Hm:noredunA (@eqk elt) m) m' (Hm':noredunA (@eqk elt') m')(x:key), 
+  In x (map2 m m') -> In x m \/ In x m'. 
+Proof.
+ intros.
+ destruct H as (e,H).
+ generalize (map2_0 Hm Hm' x).
+ rewrite (find_1 (map2_noredun Hm Hm') H).
+ generalize (@find_2 _ m x).
+ generalize (@find_2 _ m' x).
+ destruct (find x m); 
+   destruct (find x m'); simpl; intros.
+ left; exists e0; auto. 
+ left; exists e0; auto.
+ right; exists e0; auto.
+ discriminate.
+Qed.
+
+End Elt3.
+End Raw.
+
+
+Module Make (X: DecidableType) <: S with Module E:=X.
+ Module Raw := Raw X. 
+
+ Module E := X.
+ Definition key := X.t. 
+
+ Record slist (elt:Set) : Set :=  
+  {this :> Raw.t elt; noredun : noredunA (@Raw.PX.eqk elt) this}.
+ Definition t (elt:Set) := slist elt. 
+
+ Section Elt. 
+ Variable elt elt' elt'':Set. 
+
+ Implicit Types m : t elt.
+
+ Definition empty := Build_slist (Raw.empty_noredun elt).
+ Definition is_empty m := Raw.is_empty m.(this).
+ Definition add x e m := Build_slist (Raw.add_noredun m.(noredun) x e).
+ Definition find x m := Raw.find x m.(this).
+ Definition remove x m := Build_slist (Raw.remove_noredun m.(noredun) x). 
+ Definition mem x m := Raw.mem x m.(this).
+ Definition map f m : t elt' := Build_slist (Raw.map_noredun m.(noredun) f).
+ Definition mapi f m : t elt' := Build_slist (Raw.mapi_noredun m.(noredun) f).
+ Definition map2 f m (m':t elt') : t elt'' := 
+ Build_slist (Raw.map2_noredun f m.(noredun) m'.(noredun)).
+ Definition elements m := @Raw.elements elt m.(this).
+ Definition fold A f m i := @Raw.fold elt A f m.(this) i.
+ Definition equal cmp m m' := @Raw.equal elt cmp m.(this) m'.(this).
+
+ Definition MapsTo x e m := Raw.PX.MapsTo x e m.(this).
+ Definition In x m := Raw.PX.In x m.(this).
+ Definition Empty m := Raw.Empty m.(this).
+ Definition Equal cmp m m' := @Raw.Equal elt cmp m.(this) m'.(this).
+
+ Definition eq_key (p p':key*elt) := X.eq (fst p) (fst p').
+ 
+ Definition eq_key_elt (p p':key*elt) := 
+      X.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+ Definition MapsTo_1 m := @Raw.PX.MapsTo_eq elt m.(this).
+
+ Definition mem_1 m := @Raw.mem_1 elt m.(this) m.(noredun).
+ Definition mem_2 m := @Raw.mem_2 elt m.(this) m.(noredun).
+
+ Definition empty_1 := @Raw.empty_1.
+
+ Definition is_empty_1 m := @Raw.is_empty_1 elt m.(this).
+ Definition is_empty_2 m := @Raw.is_empty_2 elt m.(this).
+
+ Definition add_1 m := @Raw.add_1 elt m.(this).
+ Definition add_2 m := @Raw.add_2 elt m.(this).
+ Definition add_3 m := @Raw.add_3 elt m.(this).
+
+ Definition remove_1 m := @Raw.remove_1 elt m.(this) m.(noredun).
+ Definition remove_2 m := @Raw.remove_2 elt m.(this) m.(noredun).
+ Definition remove_3 m := @Raw.remove_3 elt m.(this) m.(noredun).
+
+ Definition find_1 m := @Raw.find_1 elt m.(this) m.(noredun).
+ Definition find_2 m := @Raw.find_2 elt m.(this).
+
+ Definition elements_1 m := @Raw.elements_1 elt m.(this).
+ Definition elements_2 m := @Raw.elements_2 elt m.(this).
+ Definition elements_3 m := @Raw.elements_3 elt m.(this) m.(noredun).
+
+ Definition fold_1 m := @Raw.fold_1 elt m.(this).
+
+ Definition map_1 m := @Raw.map_1 elt elt' m.(this).
+ Definition map_2 m := @Raw.map_2 elt elt' m.(this).
+
+ Definition mapi_1 m := @Raw.mapi_1 elt elt' m.(this).
+ Definition mapi_2 m := @Raw.mapi_2 elt elt' m.(this).
+
+ Definition map2_1 m (m':t elt') x f := 
+  @Raw.map2_1 elt elt' elt'' f m.(this) m.(noredun) m'.(this) m'.(noredun) x.
+ Definition map2_2 m (m':t elt') x f := 
+  @Raw.map2_2 elt elt' elt'' f m.(this) m.(noredun) m'.(this) m'.(noredun) x.
+
+ Definition equal_1 m m' := @Raw.equal_1 elt m.(this) m.(noredun) m'.(this) m'.(noredun).
+ Definition equal_2 m m' := @Raw.equal_2 elt m.(this) m.(noredun) m'.(this) m'.(noredun).
+
+ End Elt.
+End Make.
+
+
diff --git a/theories/FSets/FSet.v b/theories/FSets/FSet.v
new file mode 100644
index 000000000..232eb2912
--- /dev/null
+++ b/theories/FSets/FSet.v
@@ -0,0 +1,16 @@
+(***********************************************************************)
+(*  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: FSet.v,v 1.2 2004/12/08 19:19:24 letouzey Exp $ *)
+
+Require Export OrderedType.
+Require Export FSetInterface.
+Require Export FSetBridge.
+Require Export FSetProperties.
+Require Export FSetEqProperties.
+Require Export FSetList.
diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v
new file mode 100644
index 000000000..4296f619f
--- /dev/null
+++ b/theories/FSets/FSetBridge.v
@@ -0,0 +1,750 @@
+(***********************************************************************)
+(*  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: FSetBridge.v,v 1.6 2006/03/09 18:34:51 letouzey Exp $ *)
+
+(** * Finite sets library *)
+
+(** This module implements bridges (as functors) from dependent
+    to/from non-dependent set signature. *)
+
+Require Export FSetInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+Set Firstorder Depth 2.
+
+(** * From non-dependent signature [S] to dependent signature [Sdep]. *)
+
+Module DepOfNodep (M: S) <: Sdep with Module E := M.E.
+  Import M.
+
+  Module ME := OrderedTypeFacts E.
+   
+  Definition empty : {s : t | Empty s}.
+  Proof. 
+    exists empty; auto.
+  Qed.
+
+  Definition is_empty : forall s : t, {Empty s} + {~ Empty s}.
+  Proof. 
+    intros; generalize (is_empty_1 (s:=s)) (is_empty_2 (s:=s)).
+    case (is_empty s); intuition.
+  Qed.
+
+
+  Definition mem : forall (x : elt) (s : t), {In x s} + {~ In x s}.
+  Proof. 
+    intros; generalize (mem_1 (s:=s) (x:=x)) (mem_2 (s:=s) (x:=x)).
+    case (mem x s); intuition.
+  Qed.
+ 
+  Definition Add (x : elt) (s s' : t) :=
+    forall y : elt, In y s' <-> E.eq x y \/ In y s.
+ 
+  Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}.
+  Proof.
+    intros; exists (add x s); auto.
+    unfold Add in |- *; intuition.
+    elim (ME.eq_dec x y); auto.
+    intros; right. 
+    eapply add_3; eauto.
+  Qed. 
+ 
+  Definition singleton :
+    forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}.
+  Proof. 
+    intros; exists (singleton x); intuition.
+  Qed.
+ 
+  Definition remove :
+    forall (x : elt) (s : t),
+    {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.
+    apply In_1 with y; auto. 
+    elim (ME.eq_dec x y); intros; auto.
+    absurd (In x (remove x s)); auto.
+    apply In_1 with y; auto. 
+    eauto.
+  Qed.
+
+  Definition union :
+    forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}.
+  Proof.
+    intros; exists (union s s'); intuition.
+  Qed.    
+
+  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.
+  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. 
+  Qed. 
+ 
+  Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}.
+  Proof. 
+    intros. 
+    generalize (equal_1 (s:=s) (s':=s')) (equal_2 (s:=s) (s':=s')).
+    case (equal s s'); intuition.
+  Qed.
+
+  Definition subset : forall s s' : t, {Subset s s'} + {~Subset s s'}.
+  Proof. 
+    intros. 
+    generalize (subset_1 (s:=s) (s':=s')) (subset_2 (s:=s) (s':=s')).
+    case (subset s s'); intuition.
+  Qed.   
+
+  Definition elements :
+    forall s : t,
+    {l : list elt | ME.Sort l /\ (forall x : elt, In x s <-> ME.In x l)}.
+   Proof.
+     intros; exists (elements s); intuition.   
+   Defined. 
+
+  Definition fold :
+    forall (A : Set) (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. 
+  intros; exists (fold (A:=A) f s i); exact (fold_1 s i f).
+  Qed.
+
+  Definition cardinal :
+      forall s : t,
+      {r : nat | let (l,_) := elements s in r = length l }.
+  Proof.
+    intros; exists (cardinal s); exact (cardinal_1 s).
+  Qed.    
+
+  Definition fdec (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+    (x : elt) := if Pdec x then true else false. 
+
+  Lemma compat_P_aux :
+   forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}),
+   compat_P E.eq P -> compat_bool E.eq (fdec Pdec).
+  Proof.
+    unfold compat_P, compat_bool, fdec in |- *; intros.
+    generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder.
+  Qed.
+
+  Hint Resolve compat_P_aux.
+
+  Definition filter :
+    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
+    {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}.
+  Proof.
+    intros. 
+    exists (filter (fdec Pdec) s).
+    intro H; assert (compat_bool E.eq (fdec Pdec)); auto.
+    intuition.
+    eauto.
+    generalize (filter_2 H0 H1).
+    unfold fdec in |- *.
+    case (Pdec x); intuition.
+    inversion H2.
+    apply filter_3; auto.
+    unfold fdec in |- *; simpl in |- *.
+    case (Pdec x); intuition.
+  Qed.
+
+  Definition for_all :
+    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
+    {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}.
+  Proof. 
+    intros. 
+    generalize (for_all_1 (s:=s) (f:=fdec Pdec))
+     (for_all_2 (s:=s) (f:=fdec Pdec)).
+    case (for_all (fdec Pdec) s); unfold For_all in |- *; [ left | right ];
+     intros.
+    assert (compat_bool E.eq (fdec Pdec)); auto.
+    generalize (H0 H3 (refl_equal _) _ H2).
+    unfold fdec in |- *. 
+    case (Pdec x); intuition.
+    inversion H4.
+    intuition.    
+    absurd (false = true); [ auto with bool | apply H; auto ].
+    intro.
+    unfold fdec in |- *. 
+    case (Pdec x); intuition.
+  Qed.
+
+  Definition exists_ :
+    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
+    {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}.
+  Proof. 
+    intros. 
+    generalize (exists_1 (s:=s) (f:=fdec Pdec))
+     (exists_2 (s:=s) (f:=fdec Pdec)).
+    case (exists_ (fdec Pdec) s); unfold Exists in |- *; [ left | right ];
+     intros.
+    elim H0; auto; intros.
+    exists x; intuition.
+    generalize H4.
+    unfold fdec in |- *. 
+    case (Pdec x); intuition.
+    inversion H2.
+    intuition. 
+    elim H2; intros.    
+    absurd (false = true); [ auto with bool | apply H; auto ].
+    exists x; intuition.
+    unfold fdec in |- *. 
+    case (Pdec x); intuition.
+  Qed.
+
+  Definition partition :
+    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
+    {partition : t * t |
+    let (s1, s2) := partition in
+    compat_P E.eq P ->
+    For_all P s1 /\
+    For_all (fun x => ~ P x) s2 /\
+    (forall x : elt, In x s <-> In x s1 \/ In x s2)}.
+  Proof.
+    intros.
+    exists (partition (fdec Pdec) s).
+    generalize (partition_1 s (f:=fdec Pdec)) (partition_2 s (f:=fdec Pdec)).
+    case (partition (fdec Pdec) s).
+    intros s1 s2; simpl in |- *.
+    intros; assert (compat_bool E.eq (fdec Pdec)); auto.
+    intros; assert (compat_bool E.eq (fun x => negb (fdec Pdec x))).
+    generalize H2; unfold compat_bool in |- *; intuition;
+     apply (f_equal negb); auto.
+    intuition.
+    generalize H4; unfold For_all, Equal in |- *; intuition.
+    elim (H0 x); intros.
+    assert (fdec Pdec x = true).
+     eauto.      
+    generalize H8; unfold fdec in |- *; case (Pdec x); intuition.
+    inversion H9.
+    generalize H; unfold For_all, Equal in |- *; intuition.
+    elim (H0 x); intros.
+    cut ((fun x => negb (fdec Pdec x)) x = true). 
+    unfold fdec in |- *; case (Pdec x); intuition.
+      change ((fun x => negb (fdec Pdec x)) x = true) in |- *.
+      apply (filter_2 (s:=s) (x:=x)); auto.
+    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.
+    apply filter_3; auto.
+    rewrite H5; auto.
+    eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B;
+     auto.
+    eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; 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.    
+  Qed.
+
+  Definition min_elt :
+    forall s : t,
+    {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}.
+  Proof. 
+    intros;
+     generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)).
+    case (min_elt s); [ left | right ]; auto.    
+    exists e; unfold For_all in |- *; eauto.
+  Qed. 
+
+  Definition max_elt :
+    forall s : t,
+    {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}.
+  Proof. 
+    intros;
+     generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)).
+    case (max_elt s); [ left | right ]; auto.    
+    exists e; unfold For_all in |- *; eauto.
+  Qed. 
+
+  Module E := E. 
+
+  Definition elt := elt.
+  Definition t := t.
+
+  Definition In := In. 
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) (s : t) :=
+    forall x : elt, In x s -> P x.
+  Definition Exists (P : elt -> Prop) (s : t) :=
+    exists x : elt, In x s /\ P x.
+  
+  Definition eq_In := In_1.
+
+  Definition eq := Equal.
+  Definition lt := lt.
+  Definition eq_refl := eq_refl.
+  Definition eq_sym := eq_sym.
+  Definition eq_trans := eq_trans.
+  Definition lt_trans := lt_trans. 
+  Definition lt_not_eq := lt_not_eq.
+  Definition compare := compare.
+
+End DepOfNodep.
+
+
+(** * From dependent signature [Sdep] to non-dependent signature [S]. *)
+
+Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
+  Import M.
+
+  Module ME := OrderedTypeFacts E.
+
+  Definition empty : t := let (s, _) := empty in s.
+
+  Lemma empty_1 : Empty empty.
+  Proof.
+    unfold empty in |- *; case M.empty; auto.
+  Qed.
+
+  Definition is_empty (s : t) : bool :=
+    if is_empty s then true else false.
+
+  Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true.
+  Proof.
+    intros; unfold is_empty in |- *; case (M.is_empty s); auto.
+  Qed.
+
+  Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s.
+  Proof.
+    intro s; unfold is_empty in |- *; case (M.is_empty s); auto.
+    intros; discriminate H.
+  Qed.
+
+  Definition mem (x : elt) (s : t) : bool :=
+    if mem x s then true else false.
+
+  Lemma mem_1 : forall (s : t) (x : elt), In x s -> mem x s = true.
+  Proof.
+    intros; unfold mem in |- *; case (M.mem x s); auto.
+  Qed.
+   
+  Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
+  Proof.
+    intros s x; unfold mem in |- *; case (M.mem x s); auto.
+    intros; discriminate H.
+  Qed.
+
+  Definition equal (s s' : t) : bool :=
+    if equal s s' then true else false.
+
+  Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true.
+  Proof. 
+    intros; unfold equal in |- *; case M.equal; intuition.
+  Qed.    
+ 
+  Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'.
+  Proof. 
+    intros s s'; unfold equal in |- *; case (M.equal s s'); intuition;
+     inversion H.
+  Qed.
+  
+  Definition subset (s s' : t) : bool :=
+    if subset s s' then true else false.
+
+  Lemma subset_1 : forall s s' : t, Subset s s' -> subset s s' = true.
+  Proof. 
+    intros; unfold subset in |- *; case M.subset; intuition.
+  Qed.    
+ 
+  Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'.
+  Proof. 
+    intros s s'; unfold subset in |- *; case (M.subset s s'); intuition;
+     inversion H.
+  Qed.
+
+  Definition choose (s : t) : option elt :=
+    match choose s with
+    | inleft (exist x _) => Some x
+    | inright _ => None
+    end.
+
+  Lemma choose_1 : forall (s : t) (x : elt), choose s = Some x -> In x s.
+  Proof.
+    intros s x; unfold choose in |- *; case (M.choose s).
+    simple destruct s0; intros; injection H; intros; subst; auto.
+    intros; discriminate H.
+  Qed.
+
+  Lemma choose_2 : forall s : t, choose s = None -> Empty s.
+  Proof.
+    intro s; unfold choose in |- *; case (M.choose s); auto.
+    simple destruct s0; intros; discriminate H.
+  Qed.
+
+  Definition elements (s : t) : list elt := let (l, _) := elements s in l. 
+ 
+  Lemma elements_1 : forall (s : t) (x : elt), In x s -> ME.In x (elements s).
+  Proof. 
+    intros; unfold elements in |- *; case (M.elements s); firstorder.
+  Qed.
+
+  Lemma elements_2 : forall (s : t) (x : elt), ME.In x (elements s) -> In x s.
+  Proof. 
+    intros s x; unfold elements in |- *; case (M.elements s); firstorder.
+  Qed.
+
+  Lemma elements_3 : forall s : t, ME.Sort (elements s).  
+  Proof. 
+    intros; unfold elements in |- *; case (M.elements s); firstorder.
+  Qed.
+
+  Definition min_elt (s : t) : option elt :=
+    match min_elt s with
+    | inleft (exist x _) => Some x
+    | inright _ => None
+    end.
+
+  Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. 
+  Proof.
+    intros s x; unfold min_elt in |- *; case (M.min_elt s).
+    simple destruct s0; intros; injection H; intros; subst; intuition.
+    intros; discriminate H.
+  Qed. 
+
+  Lemma min_elt_2 :
+   forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. 
+  Proof.
+    intros s x y; unfold min_elt in |- *; case (M.min_elt s).
+    unfold For_all in |- *; simple destruct s0; intros; injection H; intros;
+     subst; firstorder.
+    intros; discriminate H.
+  Qed. 
+
+  Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s.
+  Proof.
+    intros s; unfold min_elt in |- *; case (M.min_elt s); auto.
+    simple destruct s0; intros; discriminate H.
+  Qed. 
+
+  Definition max_elt (s : t) : option elt :=
+    match max_elt s with
+    | inleft (exist x _) => Some x
+    | inright _ => None
+    end.
+
+  Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. 
+  Proof.
+    intros s x; unfold max_elt in |- *; case (M.max_elt s).
+    simple destruct s0; intros; injection H; intros; subst; intuition.
+    intros; discriminate H.
+  Qed. 
+
+  Lemma max_elt_2 :
+   forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. 
+  Proof.
+    intros s x y; unfold max_elt in |- *; case (M.max_elt s).
+    unfold For_all in |- *; simple destruct s0; intros; injection H; intros;
+     subst; firstorder.
+    intros; discriminate H.
+  Qed. 
+
+  Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s.
+  Proof.
+    intros s; unfold max_elt in |- *; case (M.max_elt s); auto.
+    simple destruct s0; intros; discriminate H.
+  Qed. 
+
+  Definition add (x : elt) (s : t) : t := let (s', _) := add x s in s'.
+
+  Lemma add_1 : forall (s : t) (x y : elt), E.eq x y -> In y (add x s).
+  Proof.
+    intros; unfold add in |- *; case (M.add x s); unfold Add in |- *;
+     firstorder.
+  Qed.
+
+  Lemma add_2 : forall (s : t) (x y : elt), In y s -> In y (add x s).
+  Proof.
+    intros; unfold add in |- *; case (M.add x s); unfold Add in |- *;
+     firstorder.
+  Qed.
+
+  Lemma add_3 :
+   forall (s : t) (x y : elt), ~ E.eq x y -> In y (add x s) -> In y s.
+  Proof.
+    intros s x y; unfold add in |- *; case (M.add x s); unfold Add in |- *;
+     firstorder.
+  Qed.
+
+  Definition remove (x : elt) (s : t) : t := let (s', _) := remove x s in s'.
+
+  Lemma remove_1 : forall (s : t) (x y : elt), E.eq x y -> ~ In y (remove x s).
+  Proof.
+    intros; unfold remove in |- *; case (M.remove x s); firstorder.
+  Qed.
+
+  Lemma remove_2 :
+   forall (s : t) (x y : elt), ~ E.eq x y -> In y s -> In y (remove x s).
+  Proof.
+    intros; unfold remove in |- *; case (M.remove x s); firstorder.
+  Qed.
+
+  Lemma remove_3 : forall (s : t) (x y : elt), In y (remove x s) -> In y s.
+  Proof.
+    intros s x y; unfold remove in |- *; case (M.remove x s); firstorder.
+  Qed.
+  
+  Definition singleton (x : elt) : t := let (s, _) := singleton x in s. 
+ 
+  Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y. 
+  Proof.
+    intros x y; unfold singleton in |- *; case (M.singleton x); firstorder.
+  Qed.
+
+  Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x). 
+  Proof.
+    intros x y; unfold singleton in |- *; case (M.singleton x); firstorder.
+  Qed.
+  
+  Definition union (s s' : t) : t := let (s'', _) := union s s' in s''.
+ 
+  Lemma union_1 :
+   forall (s s' : t) (x : elt), In x (union s s') -> In x s \/ In x s'.
+  Proof. 
+    intros s s' x; unfold union in |- *; case (M.union s s'); firstorder.
+  Qed.
+
+  Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s'). 
+  Proof. 
+    intros s s' x; unfold union in |- *; case (M.union s s'); firstorder.
+  Qed.
+
+  Lemma union_3 : forall (s s' : t) (x : elt), In x s' -> In x (union s s').
+  Proof. 
+    intros s s' x; unfold union in |- *; case (M.union s s'); firstorder.
+  Qed.
+
+  Definition inter (s s' : t) : t := let (s'', _) := inter s s' in s''.
+ 
+  Lemma inter_1 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s.
+  Proof. 
+    intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder.
+  Qed.
+
+  Lemma inter_2 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s'.
+  Proof. 
+    intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder.
+  Qed.
+
+  Lemma inter_3 :
+   forall (s s' : t) (x : elt), In x s -> In x s' -> In x (inter s s').
+  Proof. 
+    intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder.
+  Qed.
+
+  Definition diff (s s' : t) : t := let (s'', _) := diff s s' in s''.
+ 
+  Lemma diff_1 : forall (s s' : t) (x : elt), In x (diff s s') -> In x s.
+  Proof. 
+    intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder.
+  Qed.
+
+  Lemma diff_2 : forall (s s' : t) (x : elt), In x (diff s s') -> ~ In x s'.
+  Proof. 
+    intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder.
+  Qed.
+
+  Lemma diff_3 :
+   forall (s s' : t) (x : elt), In x s -> ~ In x s' -> In x (diff s s').
+  Proof. 
+    intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder.
+  Qed.
+
+  Definition cardinal (s : t) : nat := let (f, _) := cardinal s in f.
+
+  Lemma cardinal_1 : forall s, cardinal s = length (elements s).
+  Proof.
+    intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *; 
+    destruct (M.elements s); auto.
+  Qed.
+
+  Definition fold (B : Set) (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),
+   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 *; 
+    destruct (M.elements s); auto.
+  Qed.  
+
+  Definition f_dec :
+    forall (f : elt -> bool) (x : elt), {f x = true} + {f x <> true}.
+  Proof.
+    intros; case (f x); auto with bool.
+  Defined. 
+
+  Lemma compat_P_aux :
+   forall f : elt -> bool,
+   compat_bool E.eq f -> compat_P E.eq (fun x => f x = true).
+  Proof.
+     unfold compat_bool, compat_P in |- *; intros; rewrite <- H1; firstorder.
+  Qed.
+
+  Hint Resolve compat_P_aux.
+    
+  Definition filter (f : elt -> bool) (s : t) : t :=
+    let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'.
+
+  Lemma filter_1 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool E.eq f -> In x (filter f s) -> In x s.
+  Proof.
+    intros s x f; unfold filter in |- *; case M.filter; intuition.
+    generalize (i (compat_P_aux H)); firstorder.
+  Qed.
+
+  Lemma filter_2 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool E.eq f -> In x (filter f s) -> f x = true. 
+  Proof.
+    intros s x f; unfold filter in |- *; case M.filter; intuition.
+    generalize (i (compat_P_aux H)); firstorder.
+  Qed.
+
+  Lemma filter_3 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).     
+  Proof.
+    intros s x f; unfold filter in |- *; case M.filter; intuition.
+    generalize (i (compat_P_aux H)); firstorder.
+  Qed.
+
+  Definition for_all (f : elt -> bool) (s : t) : bool :=
+    if for_all (P:=fun x => f x = true) (f_dec f) s
+    then true
+    else false. 
+
+  Lemma for_all_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f ->
+   For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof. 
+    intros s f; unfold for_all in |- *; case M.for_all; intuition; elim n;
+     auto.
+  Qed.
+ 
+  Lemma for_all_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f ->
+   for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof. 
+    intros s f; unfold for_all in |- *; case M.for_all; intuition;
+     inversion H0.
+  Qed.
+  
+  Definition exists_ (f : elt -> bool) (s : t) : bool :=
+    if exists_ (P:=fun x => f x = true) (f_dec f) s
+    then true
+    else false. 
+
+  Lemma exists_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof. 
+    intros s f; unfold exists_ in |- *; case M.exists_; intuition; elim n;
+     auto.
+  Qed.
+ 
+  Lemma exists_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof. 
+    intros s f; unfold exists_ in |- *; case M.exists_; intuition;
+     inversion H0.
+  Qed.
+     
+  Definition partition (f : elt -> bool) (s : t) : 
+    t * t :=
+    let (p, _) := partition (P:=fun x => f x = true) (f_dec f) s in p.
+  
+  Lemma partition_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
+  Proof.
+    intros s f; unfold partition in |- *; case M.partition. 
+    intro p; case p; clear p; intros s1 s2 H C. 
+    generalize (H (compat_P_aux C)); clear H; intro H.
+    simpl in |- *; unfold Equal in |- *; intuition.
+    apply filter_3; firstorder. 
+    elim (H2 a); intros. 
+    assert (In a s). 
+     eapply filter_1; eauto.
+    elim H3; intros; auto.
+    absurd (f a = true).
+    exact (H a H6).
+    eapply filter_2; eauto. 
+  Qed.    
+    
+  Lemma partition_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof.
+    intros s f; unfold partition in |- *; case M.partition. 
+    intro p; case p; clear p; intros s1 s2 H C. 
+    generalize (H (compat_P_aux C)); clear H; intro H.
+    assert (D : compat_bool E.eq (fun x => negb (f x))).
+    generalize C; unfold compat_bool in |- *; intros; apply (f_equal negb);
+     auto.
+    simpl in |- *; unfold Equal in |- *; intuition.
+    apply filter_3; firstorder.
+    elim (H2 a); intros. 
+    assert (In a s). 
+     eapply filter_1; eauto.
+    elim H3; intros; auto.
+    absurd (f a = true).
+    intro.
+    generalize (filter_2 D H1). 
+    rewrite H7; intros H8; inversion H8.
+    exact (H0 a H6).
+  Qed. 
+
+
+  Module E := E. 
+  Definition elt := elt.
+  Definition t := t.
+
+  Definition In := In. 
+  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 Add (x : elt) (s s' : t) :=
+    forall y : elt, In y s' <-> E.eq y x \/ In y s.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) (s : t) :=
+    forall x : elt, In x s -> P x.
+  Definition Exists (P : elt -> Prop) (s : t) :=
+    exists x : elt, In x s /\ P x.
+
+  Definition In_1 := eq_In.
+
+  Definition eq := Equal.
+  Definition lt := lt.
+  Definition eq_refl := eq_refl.
+  Definition eq_sym := eq_sym.
+  Definition eq_trans := eq_trans.
+  Definition lt_trans := lt_trans. 
+  Definition lt_not_eq := lt_not_eq.
+  Definition compare := compare.
+
+End NodepOfDep.
diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v
new file mode 100644
index 000000000..2abc20799
--- /dev/null
+++ b/theories/FSets/FSetEqProperties.v
@@ -0,0 +1,923 @@
+(***********************************************************************)
+(*  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: FSetEqProperties.v,v 1.10 2006/03/14 23:52:28 letouzey Exp $ *)
+
+(** * Finite sets library *)
+
+(** This module proves many properties of finite sets that 
+    are consequences of the axiomatization in [FsetInterface] 
+    Contrary to the functor in [FsetProperties] it uses 
+    sets operations instead of predicates over sets, i.e.
+    [mem x s=true] instead of [In x s], 
+    [equal s s'=true] instead of [Equal s s'], etc. *)
+
+
+Require Import FSetProperties.
+Require Import Zerob.
+Require Import Sumbool.
+Require Import Omega.
+
+Module EqProperties (M:S).
+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.
+
+Section BasicProperties. 
+
+(** Some old specifications written with boolean equalities. *) 
+
+Variable s s' s'': t.
+Variable x y z : elt.
+
+Lemma mem_eq: 
+  E.eq x y -> mem x s=mem y s.
+Proof. 
+intro H; rewrite H; auto.
+Qed.
+
+Lemma equal_mem_1: 
+  (forall a, mem a s=mem a s') -> equal s s'=true.
+Proof. 
+intros; apply equal_1; unfold Equal; intros.
+do 2 rewrite mem_iff; rewrite H; tauto.
+Qed.
+
+Lemma equal_mem_2: 
+  equal s s'=true -> forall a, mem a s=mem a s'.
+Proof. 
+intros; rewrite (equal_2 H); auto.
+Qed.
+
+Lemma subset_mem_1: 
+  (forall a, mem a s=true->mem a s'=true) -> subset s s'=true.
+Proof. 
+intros; apply subset_1; unfold Subset; intros a.
+do 2 rewrite mem_iff; auto.
+Qed.
+
+Lemma subset_mem_2: 
+  subset s s'=true -> forall a, mem a s=true -> mem a s'=true.
+Proof. 
+intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto.
+Qed.
+  
+Lemma empty_mem: mem x empty=false.
+Proof. 
+rewrite <- not_mem_iff; auto.
+Qed.
+
+Lemma is_empty_equal_empty: is_empty s = equal s empty.
+Proof. 
+apply bool_1; split; intros.
+rewrite <- (empty_is_empty_1 (s:=empty)); auto with set.
+rewrite <- is_empty_iff; auto with set.
+Qed.
+  
+Lemma choose_mem_1: choose s=Some x -> mem x s=true.
+Proof.  
+auto.
+Qed.
+
+Lemma choose_mem_2: choose s=None -> is_empty s=true.
+Proof.
+auto.
+Qed.
+
+Lemma add_mem_1: mem x (add x s)=true.
+Proof.
+auto.
+Qed.  
+ 
+Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s.
+Proof. 
+apply add_neq_b.
+Qed.
+
+Lemma remove_mem_1: mem x (remove x s)=false.
+Proof. 
+rewrite <- not_mem_iff; auto.
+Qed. 
+ 
+Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s.
+Proof. 
+apply remove_neq_b.
+Qed.
+
+Lemma singleton_equal_add: 
+  equal (singleton x) (add x empty)=true.
+Proof.
+rewrite (singleton_equal_add x); auto with set.
+Qed.  
+
+Lemma union_mem: 
+  mem x (union s s')=mem x s || mem x s'.
+Proof. 
+apply union_b.
+Qed.
+
+Lemma inter_mem: 
+  mem x (inter s s')=mem x s && mem x s'.
+Proof. 
+apply inter_b.
+Qed.
+
+Lemma diff_mem: 
+  mem x (diff s s')=mem x s && negb (mem x s').
+Proof. 
+apply diff_b.
+Qed.
+
+(** properties of [mem] *)
+
+Lemma mem_3 : ~In x s -> mem x s=false.
+Proof.
+intros; rewrite <- not_mem_iff; auto.
+Qed.
+
+Lemma mem_4 : mem x s=false -> ~In x s.
+Proof.
+intros; rewrite not_mem_iff; auto.
+Qed.
+
+(** Properties of [equal] *) 
+
+Lemma equal_refl: equal s s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma equal_sym: equal s s'=equal s' s.
+Proof.
+intros; apply bool_1; do 2 rewrite <- equal_iff; intuition.
+Qed.
+
+Lemma equal_trans: 
+ equal s s'=true -> equal s' s''=true -> equal s s''=true.
+Proof.
+intros; rewrite (equal_2 H); auto.
+Qed.
+
+Lemma equal_equal: 
+ equal s s'=true -> equal s s''=equal s' s''.
+Proof.
+intros; rewrite (equal_2 H); auto.
+Qed.
+
+Lemma equal_cardinal: 
+ equal s s'=true -> cardinal s=cardinal s'.
+Proof.
+auto with set.
+Qed.
+
+(* Properties of [subset] *)
+
+Lemma subset_refl: subset s s=true. 
+Proof.
+auto with set.
+Qed.
+
+Lemma subset_antisym: 
+ subset s s'=true -> subset s' s=true -> equal s s'=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma subset_trans: 
+ subset s s'=true -> subset s' s''=true -> subset s s''=true.
+Proof.
+do 3 rewrite <- subset_iff; intros.
+apply subset_trans with s'; auto.
+Qed.
+
+Lemma subset_equal: 
+ equal s s'=true -> subset s s'=true.
+Proof.
+auto with set.
+Qed.
+
+(** Properties of [choose] *)
+
+Lemma choose_mem_3: 
+ is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}.
+Proof.
+intros.
+generalize (@choose_1 s) (@choose_2 s).
+destruct (choose s);intros.
+exists e;auto.
+generalize (H1 (refl_equal None)); clear H1.
+intros; rewrite (is_empty_1 H1) in H; discriminate.
+Qed.
+
+Lemma choose_mem_4: choose empty=None.
+Proof.
+generalize (@choose_1 empty).
+case (@choose empty);intros;auto.
+elim (@empty_1 e); auto.
+Qed.
+
+(** Properties of [add] *)
+
+Lemma add_mem_3: 
+ mem y s=true -> mem y (add x s)=true.
+Proof.
+auto.
+Qed.
+
+Lemma add_equal: 
+ mem x s=true -> equal (add x s) s=true.
+Proof.
+auto with set.
+Qed.
+
+(** Properties of [remove] *)
+
+Lemma remove_mem_3: 
+ mem y (remove x s)=true -> mem y s=true.
+Proof.
+rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto.
+Qed.
+
+Lemma remove_equal: 
+ mem x s=false -> equal (remove x s) s=true.
+Proof.
+intros; apply equal_1; apply remove_equal.
+rewrite not_mem_iff; auto.
+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.
+Qed.
+
+Lemma remove_add: 
+ mem x s=false -> equal (remove x (add x s)) s=true.
+Proof.
+intros; apply equal_1; apply remove_add; auto.
+rewrite not_mem_iff; auto.
+Qed.
+
+(** Properties of [is_empty] *)
+
+Lemma is_empty_cardinal: is_empty s = zerob (cardinal s).
+Proof.
+intros; apply bool_1; split; intros.
+rewrite cardinal_1; simpl; auto.
+assert (cardinal s = 0) by apply zerob_true_elim; auto.
+auto.
+Qed.
+
+(** Properties of [singleton] *)
+
+Lemma singleton_mem_1: mem x (singleton x)=true.
+Proof.
+auto with set.
+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.
+Qed.
+
+Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y.
+Proof.
+auto.
+Qed.
+
+(** Properties of [union] *)
+
+Lemma union_sym:
+ equal (union s s') (union s' s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_subset_equal: 
+ subset s s'=true -> equal (union s s') s'=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_equal_1: 
+ equal s s'=true-> equal (union s s'') (union s' s'')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_equal_2: 
+ equal s' s''=true-> equal (union s s') (union s s'')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_assoc: 
+ equal (union (union s s') s'') (union s (union s' s''))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma add_union_singleton: 
+ equal (add x s) (union (singleton x) s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_add: 
+ equal (union (add x s) s') (add x (union s s'))=true.
+Proof.
+auto with set.
+Qed.
+
+(* caracterisation of [union] via [subset] *)
+
+Lemma union_subset_1: subset s (union s s')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_subset_2: subset s' (union s s')=true.
+Proof.
+auto with set.
+Qed.
+
+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.
+Qed.
+
+(** Properties of [inter] *) 
+
+Lemma inter_sym: equal (inter s s') (inter s' s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_subset_equal: 
+ subset s s'=true -> equal (inter s s') s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_equal_1: 
+ equal s s'=true -> equal (inter s s'') (inter s' s'')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_equal_2: 
+ equal s' s''=true -> equal (inter s s') (inter s s'')=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_assoc: 
+ equal (inter (inter s s') s'') (inter s (inter s' s''))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_inter_1: 
+ equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_inter_2: 
+ equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_add_1: mem x s'=true -> 
+ equal (inter (add x s) s') (add x (inter s s'))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_add_2: mem x s'=false -> 
+ equal (inter (add x s) s') (inter s s')=true.
+Proof.
+intros; apply equal_1; apply inter_add_2.
+rewrite not_mem_iff; auto.
+Qed.
+
+(* caracterisation of [union] via [subset] *)
+
+Lemma inter_subset_1: subset (inter s s') s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma inter_subset_2: subset (inter s s') s'=true.
+Proof.
+auto with set.
+Qed.
+
+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.
+Qed.
+
+(** Properties of [diff] *)
+
+Lemma diff_subset: subset (diff s s') s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma diff_subset_equal:
+ subset s s'=true -> equal (diff s s') empty=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma remove_inter_singleton: 
+ equal (remove x s) (diff s (singleton x))=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma diff_inter_empty:
+ equal (inter (diff s s') (inter s s')) empty=true. 
+Proof.
+auto with set.
+Qed.
+
+Lemma diff_inter_all: 
+ equal (union (diff s s') (inter s s')) s=true.
+Proof.
+auto with set.
+Qed.
+
+End BasicProperties.
+
+Hint Immediate empty_mem is_empty_equal_empty add_mem_1
+   remove_mem_1 singleton_equal_add union_mem inter_mem
+   diff_mem equal_sym add_remove remove_add : set. 
+Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1
+   choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal
+   subset_refl subset_equal subset_antisym
+   add_mem_3 add_equal remove_mem_3 remove_equal : set.
+
+
+(** General recursion principes based on [cardinal] *)
+
+Lemma cardinal_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.
+Proof.
+intros.
+apply cardinal_induction with n; 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 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.
+Proof.
+intros; do 2 rewrite not_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 (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.
+Proof. 
+apply fold_empty; auto.
+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.
+Qed.
+   
+Lemma fold_add: 
+ mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)).
+Proof. 
+intros; apply fold_add with (eqA:=eqA); auto.
+rewrite not_mem_iff; auto.
+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.
+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.
+Qed.
+
+Lemma remove_fold_2: 
+ mem x s=false -> eqA (fold f (remove x s) i) (fold f s i).
+Proof.
+intros; apply remove_fold_2 with (eqA:=eqA); auto.
+rewrite not_mem_iff; auto.
+Qed.
+
+Lemma fold_union: 
+ (forall x, mem x s && mem x s'=false) -> 
+ eqA (fold f (union s s') i) (fold f s (fold f s' i)).
+Proof.
+intros; apply fold_union with (eqA:=eqA); auto.
+intros; rewrite exclusive_set; auto.
+Qed.
+
+End Fold.
+
+(** Properties of [cardinal] *)
+
+Lemma add_cardinal_1: 
+ forall s x, mem x s=true -> cardinal (add x s)=cardinal s.
+Proof.
+auto with set.
+Qed.
+
+Lemma add_cardinal_2: 
+ forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s).
+Proof.
+intros; apply add_cardinal_2; auto.
+rewrite not_mem_iff; auto.
+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.
+Qed.
+
+Lemma remove_cardinal_2: 
+ forall s x, mem x s=false -> cardinal (remove x s)=cardinal s.
+Proof.
+auto with set.
+Qed.
+
+Lemma union_cardinal: 
+ forall s s', (forall x, mem x s && mem x s'=false) -> 
+ cardinal (union s s')=cardinal s+cardinal s'.
+Proof.
+intros; apply union_cardinal; auto; intros.
+rewrite exclusive_set; auto.
+Qed.
+
+Lemma subset_cardinal: 
+ forall s s', subset s s'=true -> cardinal s<=cardinal s'.
+Proof.
+intros; apply subset_cardinal; auto.
+Qed.
+
+Section Bool.
+
+(** Properties of [filter] *)
+
+Variable f:elt->bool.
+Variable Comp: compat_bool E.eq f.
+
+Let Comp' : compat_bool E.eq (fun x =>negb (f x)).
+Proof.
+unfold compat_bool in *; intros; f_equal; auto.
+Qed.
+
+Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x.
+Proof. 
+intros; apply filter_b; auto.
+Qed.
+
+Lemma for_all_filter: 
+ forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s).
+Proof. 
+intros; apply bool_1; split; intros.
+apply is_empty_1.
+unfold Empty; intros. 
+rewrite filter_iff; auto.
+red; destruct 1.
+rewrite <- (@for_all_iff s f) in H; auto.
+rewrite (H a H0) in H1; discriminate.
+apply for_all_1; auto; red; intros.
+revert H; rewrite <- is_empty_iff.
+unfold Empty; intro H; generalize (H x); clear H.
+rewrite filter_iff; auto.
+destruct (f x); auto.
+Qed.
+
+Lemma exists_filter : 
+ forall s, exists_ f s=negb (is_empty (filter f s)).
+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.
+generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)).
+destruct (choose (filter f s)).
+intros H0 _; apply exists_1; auto.
+exists e; generalize (H0 e); rewrite filter_iff; auto.
+intros _ H0.
+rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate.
+Qed.
+
+Lemma partition_filter_1: 
+ forall s, equal (fst (partition f s)) (filter f s)=true.
+Proof. 
+auto.
+Qed.
+
+Lemma partition_filter_2: 
+ forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true.
+Proof. 
+auto.
+Qed.
+
+Lemma add_filter_1 : forall s s' x, 
+ f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')).
+Proof.
+unfold Add, MP.Add; intros.
+repeat rewrite filter_iff; auto.
+rewrite H0; clear H0.
+assert (E.eq x y -> f y = true) by 
+ intro H0; rewrite <- (Comp _ _ H0); auto.
+tauto.
+Qed.
+
+Lemma add_filter_2 : forall s s' x, 
+ f x=false -> (Add x s s') -> filter f s [=] filter f s'.
+Proof.
+unfold Add, MP.Add, Equal; intros.
+repeat rewrite filter_iff; auto.
+rewrite H0; clear H0.
+assert (f a = true -> ~E.eq x a).
+ intros H0 H1.
+ rewrite (Comp _ _ H1) in H.
+ rewrite H in H0; discriminate.
+tauto. 
+Qed.
+
+Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) ->
+  forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s.
+Proof.
+clear Comp' Comp f.
+intros.
+assert (compat_bool E.eq (fun x => orb (f x) (g x))).
+  unfold compat_bool; intros.
+  rewrite (H x y H1);  rewrite (H0 x y H1); auto.
+unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto.
+assert (f a || g a = true <-> f a = true \/ g a = true).
+  split; auto with bool.
+  intro H3; destruct (orb_prop _ _ H3); auto.
+tauto.
+Qed.
+
+(** Properties of [for_all] *)
+
+Lemma for_all_mem_1: forall s, 
+ (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true.
+Proof.
+intros.
+rewrite for_all_filter; auto.
+rewrite is_empty_equal_empty.
+apply equal_mem_1;intros.
+rewrite filter_b; auto.
+rewrite empty_mem.
+generalize (H a); case (mem a s);intros;auto.
+rewrite H0;auto.
+Qed.
+
+Lemma for_all_mem_2: forall s, 
+ (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. 
+Proof.
+intros.
+rewrite for_all_filter in H; auto.
+rewrite is_empty_equal_empty in H.
+generalize (equal_mem_2 _ _ H x).
+rewrite filter_b; auto.
+rewrite empty_mem.
+rewrite H0; simpl;intros.
+replace true with (negb false);auto;apply negb_sym;auto.
+Qed.
+
+Lemma for_all_mem_3: 
+ forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false.
+Proof.
+intros.
+apply (bool_eq_ind (for_all f s));intros;auto.
+rewrite for_all_filter in H1; auto.
+rewrite is_empty_equal_empty in H1.
+generalize (equal_mem_2 _ _ H1 x).
+rewrite filter_b; auto.
+rewrite empty_mem.
+rewrite H.
+rewrite H0.
+simpl;auto.
+Qed.
+
+Lemma for_all_mem_4: 
+ forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}.
+Proof.
+intros.
+rewrite for_all_filter in H; auto.
+destruct (choose_mem_3 _ H) as (x,(H0,H1));intros.
+exists x.
+rewrite filter_b in H1; auto.
+elim (andb_prop _ _ H1).
+split;auto.
+replace false with (negb true);auto;apply negb_sym;auto.
+Qed.
+
+(** Properties of [exists] *)
+
+Lemma for_all_exists: 
+ forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s).
+Proof.
+intros.
+rewrite for_all_b; auto.
+rewrite exists_b; auto.
+induction (elements s); simpl; auto.
+destruct (f a); simpl; auto.
+Qed.
+
+End Bool.
+Section Bool'.
+
+Variable f:elt->bool.
+Variable Comp: compat_bool E.eq f.
+
+Let Comp' : compat_bool E.eq (fun x =>negb (f x)).
+Proof.
+unfold compat_bool in *; intros; f_equal; auto.
+Qed.
+
+Lemma exists_mem_1: 
+ forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false.
+Proof.
+intros.
+rewrite for_all_exists; auto.
+rewrite for_all_mem_1;auto with bool.
+intros;generalize (H x H0);intros. 
+symmetry;apply negb_sym;simpl;auto.
+Qed.
+
+Lemma exists_mem_2: 
+ forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. 
+Proof.
+intros.
+rewrite for_all_exists in H; auto.
+replace false with (negb true);auto;apply negb_sym;symmetry.
+rewrite (for_all_mem_2 (fun x => negb (f x)) Comp' s);simpl;auto.
+replace true with (negb false);auto;apply negb_sym;auto.
+Qed.
+
+Lemma exists_mem_3: 
+ forall s x, mem x s=true -> f x=true -> exists_ f s=true.
+Proof.
+intros.
+rewrite for_all_exists; auto.
+symmetry;apply negb_sym;simpl.
+apply for_all_mem_3 with x;auto.
+rewrite H0;auto.
+Qed.
+
+Lemma exists_mem_4: 
+ forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}.
+Proof.
+intros.
+rewrite for_all_exists in H; auto.
+elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros.
+elim p;intros.
+exists x;split;auto.
+replace true with (negb false);auto;apply negb_sym;auto.
+replace false with (negb true);auto;apply negb_sym;auto.
+Qed.
+
+End Bool'.
+
+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. 
+
+Lemma sum_plus : 
+  forall f g, compat_nat E.eq f -> compat_nat E.eq g -> 
+    forall s, sum (fun x =>f x+g x) s = sum f s + sum g s.
+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 (st := gen_st nat).
+intros s;pattern s; apply set_rec.
+intros.
+rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H).
+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.
+Qed.
+
+Lemma sum_filter : forall f, (compat_bool E.eq f) -> 
+  forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)).
+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.
+ rewrite (Hf x x' H); auto.
+assert (ct : transpose (@eq _) (fun x => plus (if f x then 1 else 0))).
+ unfold transpose; intros; omega.
+intros s;pattern s; apply set_rec.
+intros.
+change elt with E.t.
+rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H).
+rewrite <- (MP.Equal_cardinal (filter_equal Hf (equal_2 H))); auto.
+intros; rewrite (fold_add _ _ st _ cc ct); auto.
+generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) .
+assert (~ In x (filter f s0)).
+ intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H.
+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.
+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))
+  (f g:elt->A->A),
+  (compat_op E.eq eqA f) -> (transpose eqA f) -> 
+  (compat_op E.eq eqA g) -> (transpose eqA g) -> 
+  forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> 
+  (eqA (fold f s i) (fold g s i)).
+Proof.
+intros A eqA st f g fc ft gc gt i.
+intro s; pattern s; apply set_rec; intros.
+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.
+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)).
+sym_st; apply fold_add with (eqA:=eqA); auto.
+trans_st i; [idtac | sym_st ]; apply fold_empty; auto.
+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.
+Qed.
+
+End Sum.
+
+End EqProperties. 
diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v
new file mode 100644
index 000000000..5cf2808c5
--- /dev/null
+++ b/theories/FSets/FSetFacts.v
@@ -0,0 +1,409 @@
+(***********************************************************************)
+(*  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: FSetFacts.v,v 1.6 2006/03/13 04:59:24 letouzey Exp $ *)
+
+(** * 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 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] *)
+
+(** * 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 <-> ME.In 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 *)
+
+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 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.
+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.
+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; [apply eq_refl | apply eq_sym | apply eq_trans].
+Qed.
+
+Add Setoid t Equal Equal_ST as EqualSetoid.
+
+Add Morphism In : 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 : 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; order.
+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 : 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/FSetInterface.v b/theories/FSets/FSetInterface.v
new file mode 100644
index 000000000..ff3d7e578
--- /dev/null
+++ b/theories/FSets/FSetInterface.v
@@ -0,0 +1,416 @@
+(***********************************************************************)
+(*  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: FSetInterface.v,v 1.11 2006/03/10 10:49:48 letouzey Exp $ *)
+
+(** * Finite set library *)
+
+(** Set interfaces *)
+
+Require Export Bool.
+Require Export OrderedType.
+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 : OrderedType.
+  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. *)
+
+  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. *)
+
+  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], in increasing order. *)
+
+  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.
+  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 *)
+
+  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 *)
+
+  Section Spec. 
+
+  Variable s s' s'' : t.
+  Variable x y z : 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'.
+
+  (** Specification of [subset] *)
+  Parameter subset_1 : s[<=]s' -> subset s s' = true.
+  Parameter subset_2 : subset s s' = true -> 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 -> 
+      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.
+
+  (** 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 : sort E.lt (elements s).  
+
+  (** 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. 
+  Parameter min_elt_3 : min_elt s = None -> Empty s.
+
+  (** Specification of [max_elt] *)  
+  Parameter max_elt_1 : max_elt s = Some x -> In x 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'). *)
+
+  End Filter.
+  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 min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3.
+
+End S.
+
+(** * Dependent signature 
+
+    Signature [Sdep] presents sets using dependent types *)
+
+Module Type Sdep.
+
+  Declare Module E : OrderedType.
+  Definition elt := E.t.
+
+  Parameter t : Set.
+
+  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 Add x s s' := forall y, In y s' <-> E.eq x y \/ In y 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).
+
+  Definition eq : t -> t -> Prop := Equal.
+  Parameter lt : t -> t -> Prop.
+  Parameter compare : forall s s' : t, Compare lt eq s s'.
+
+  Parameter eq_refl : forall s : t, eq s s. 
+  Parameter eq_sym : forall s s' : t, eq s s' -> eq s' s.
+  Parameter eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''.
+  Parameter lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''.
+  Parameter lt_not_eq : forall s s' : t, lt s s' -> ~ eq s s'.
+
+  Parameter eq_In : forall (s : t) (x y : elt), E.eq x y -> In x s -> In y s.
+
+  Parameter empty : {s : t | Empty s}.
+
+  Parameter is_empty : forall s : t, {Empty s} + {~ Empty s}.
+
+  Parameter mem : forall (x : elt) (s : t), {In x s} + {~ In x s}.
+
+  Parameter add : forall (x : elt) (s : t), {s' : t | Add x s s'}.
+
+  Parameter
+    singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}.
+  
+  Parameter
+    remove :
+      forall (x : elt) (s : t),
+      {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}.
+
+  Parameter
+    union :
+      forall s s' : t,
+      {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}.
+
+  Parameter
+    inter :
+      forall s s' : t,
+      {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}.
+
+  Parameter
+    diff :
+      forall s s' : t,
+      {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}.
+
+  Parameter equal : forall s s' : t, {s[=]s'} + {~ s[=]s'}.
+ 
+  Parameter subset : forall s s' : t, {Subset s s'} + {~ Subset s s'}.
+
+  Parameter
+    filter :
+      forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+        (s : t),
+      {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}.
+
+  Parameter
+    for_all :
+      forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+        (s : t),
+      {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}.
+  
+  Parameter
+    exists_ :
+      forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+        (s : t),
+      {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}.
+
+  Parameter
+    partition :
+      forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+        (s : t),
+      {partition : t * t |
+      let (s1, s2) := partition in
+      compat_P E.eq P ->
+      For_all P s1 /\
+      For_all (fun x => ~ P x) s2 /\
+      (forall x : elt, In x s <-> In x s1 \/ In x s2)}.
+
+  Parameter
+    elements :
+      forall s : t,
+      {l : list elt |
+      sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}.
+
+  Parameter
+    fold :
+      forall (A : Set) (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}.
+
+  Parameter
+    cardinal :
+      forall s : t,
+      {r : nat | let (l,_) := elements s in r = length l }.
+
+  Parameter
+    min_elt :
+      forall s : t,
+      {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}.
+
+  Parameter
+    max_elt :
+      forall s : t,
+      {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}.
+
+  Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}.
+
+End Sdep.
diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v
new file mode 100644
index 000000000..444327574
--- /dev/null
+++ b/theories/FSets/FSetList.v
@@ -0,0 +1,1163 @@
+(***********************************************************************)
+(*  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: FSetList.v,v 1.12 2006/03/10 10:49:48 letouzey Exp $ *)
+
+(** * Finite sets library *)
+
+(** This file proposes an implementation of the non-dependant 
+    interface [FSetInterface.S] using strictly ordered list. *)
+
+Require Export FSetInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Functions over lists
+
+   First, we provide sets as lists which are not necessarily sorted.
+   The specs are proved under the additional condition of being sorted. 
+   And the functions returning sets are proved to preserve this invariant. *)
+
+Module Raw (X: OrderedType).
+ 
+  Module E := X.
+  Module MX := OrderedTypeFacts X.
+  Import MX.
+
+  Definition elt := X.t.
+  Definition t := list elt.
+
+  Definition empty : t := nil.
+
+  Definition is_empty (l : t) : bool := if l then true else false.
+
+  (** ** The set operations. *)
+
+  Fixpoint mem (x : elt) (s : t) {struct s} : bool :=
+    match s with
+    | nil => false
+    | y :: l =>
+        match X.compare x y with
+        | Lt _ => false
+        | Eq _ => true
+        | Gt _ => mem x l
+        end
+    end.
+
+  Fixpoint add (x : elt) (s : t) {struct s} : t :=
+    match s with
+    | nil => x :: nil
+    | y :: l =>
+        match X.compare x y with
+        | Lt _ => x :: s
+        | Eq _ => s
+        | Gt _ => y :: add x l
+        end
+    end.
+
+  Definition singleton (x : elt) : t := x :: nil. 
+
+  Fixpoint remove (x : elt) (s : t) {struct s} : t :=
+    match s with
+    | nil => nil
+    | y :: l =>
+        match X.compare x y with
+        | Lt _ => s
+        | Eq _ => l
+        | Gt _ => y :: remove x l
+        end
+    end.  
+  
+  Fixpoint union (s : t) : t -> t :=
+    match s with
+    | nil => fun s' => s'
+    | x :: l =>
+        (fix union_aux (s' : t) : t :=
+           match s' with
+           | nil => s
+           | x' :: l' =>
+               match X.compare x x' with
+               | Lt _ => x :: union l s'
+               | Eq _ => x :: union l l'
+               | Gt _ => x' :: union_aux l'
+               end
+           end)
+    end.      
+
+  Fixpoint inter (s : t) : t -> t :=
+    match s with
+    | nil => fun _ => nil
+    | x :: l =>
+        (fix inter_aux (s' : t) : t :=
+           match s' with
+           | nil => nil
+           | x' :: l' =>
+               match X.compare x x' with
+               | Lt _ => inter l s'
+               | Eq _ => x :: inter l l'
+               | Gt _ => inter_aux l'
+               end
+           end)
+    end.  
+  
+  Fixpoint diff (s : t) : t -> t :=
+    match s with
+    | nil => fun _ => nil
+    | x :: l =>
+        (fix diff_aux (s' : t) : t :=
+           match s' with
+           | nil => s
+           | x' :: l' =>
+               match X.compare x x' with
+               | Lt _ => x :: diff l s'
+               | Eq _ => diff l l'
+               | Gt _ => diff_aux l'
+               end
+           end)
+    end.  
+   
+  Fixpoint equal (s : t) : t -> bool :=
+    fun s' : t =>
+    match s, s' with
+    | nil, nil => true
+    | x :: l, x' :: l' =>
+        match X.compare x x' with
+        | Eq _ => equal l l'
+        | _ => false
+        end
+    | _, _ => false
+    end.
+
+  Fixpoint subset (s s' : t) {struct s'} : bool :=
+    match s, s' with
+    | nil, _ => true
+    | x :: l, x' :: l' =>
+        match X.compare x x' with
+        | Lt _ => false
+        | Eq _ => subset l l'
+        | Gt _ => subset s l'
+        end
+    | _, _ => false
+    end.
+
+  Fixpoint fold (B : Set) (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)
+                      end.  
+
+  Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t :=
+    match s with
+    | nil => nil
+    | x :: l => if f x then x :: filter f l else filter f l
+    end.  
+
+  Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool :=
+    match s with
+    | nil => true
+    | x :: l => if f x then for_all f l else false
+    end.  
+ 
+  Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool :=
+    match s with
+    | nil => false
+    | x :: l => if f x then true else exists_ f l
+    end.
+
+  Fixpoint partition (f : elt -> bool) (s : t) {struct s} : 
+   t * t :=
+    match s with
+    | nil => (nil, nil)
+    | x :: l =>
+        let (s1, s2) := partition f l in
+        if f x then (x :: s1, s2) else (s1, x :: s2)
+    end.
+
+  Definition cardinal (s : t) : nat := length s.
+
+  Definition elements (x : t) : list elt := x.
+
+  Definition min_elt (s : t) : option elt :=
+    match s with
+    | nil => None
+    | x :: _ => Some x
+    end.
+
+  Fixpoint max_elt (s : t) : option elt :=
+    match s with
+    | nil => None
+    | x :: nil => Some x
+    | _ :: l => max_elt l
+    end.
+
+  Definition choose := min_elt.
+
+  (** ** Proofs of set operation specifications. *)
+
+  Notation Sort := (sort X.lt).
+  Notation Inf := (lelistA X.lt).
+  Notation In := (InA X.eq).
+
+  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 : t) := exists x, In x s /\ P x.
+
+  Lemma mem_1 :
+   forall (s : t) (Hs : Sort s) (x : elt), In x s -> mem x s = true. 
+  Proof.
+  simple induction s; intros.
+  inversion H.
+  inversion_clear Hs.
+  inversion_clear H0.
+  simpl; elim_comp; trivial.
+  simpl; elim_comp_gt x a; auto.
+  apply Sort_Inf_In with l; trivial.
+  Qed.
+
+  Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
+  Proof.
+  simple induction s.
+  intros; inversion H.
+  intros a l Hrec x.
+  simpl.
+  case (X.compare x a); intros; try discriminate; auto.
+  Qed.
+
+  Lemma add_Inf :
+   forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s).
+  Proof.
+  simple induction s.  
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); intuition; inversion H0;
+   intuition.
+  Qed.
+  Hint Resolve add_Inf.
+  
+  Lemma add_sort : forall (s : t) (Hs : Sort s) (x : elt), Sort (add x s).
+  Proof.
+  simple induction s.
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); intuition; inversion_clear Hs;
+   auto.
+  Qed. 
+
+  Lemma add_1 :
+   forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> In y (add x s).
+  Proof.
+  simple induction s. 
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); inversion_clear Hs; auto.
+  constructor; apply X.eq_trans with x; auto.
+  Qed.
+
+  Lemma add_2 :
+   forall (s : t) (Hs : Sort s) (x y : elt), In y s -> In y (add x s).
+  Proof.
+  simple induction s. 
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); intuition.
+  inversion_clear Hs; inversion_clear H0; auto.
+  Qed.
+
+  Lemma add_3 :
+   forall (s : t) (Hs : Sort s) (x y : elt),
+   ~ X.eq x y -> In y (add x s) -> In y s.
+  Proof.
+  simple induction s. 
+  simpl; inversion_clear 3; auto; order.
+  simpl; intros a l Hrec Hs x y; case (X.compare x a); intros;
+   inversion_clear H0; inversion_clear Hs; auto.
+  order.
+  constructor 2; apply Hrec with x; auto.
+  Qed.
+
+  Lemma remove_Inf :
+   forall (s : t) (Hs : Sort s) (x a : elt), Inf a s -> Inf a (remove x s).
+  Proof.
+  simple induction s.  
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); intuition; inversion_clear H0; auto.
+  inversion_clear Hs; apply Inf_lt with a; auto.
+  Qed.
+  Hint Resolve remove_Inf.
+
+  Lemma remove_sort :
+   forall (s : t) (Hs : Sort s) (x : elt), Sort (remove x s).
+  Proof.
+  simple induction s.
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; auto.
+  Qed. 
+
+  Lemma remove_1 :
+   forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> ~ In y (remove x s).
+  Proof.
+  simple induction s. 
+  simpl; red; intros; inversion H0.
+  simpl; intros; case (X.compare x a); intuition; inversion_clear Hs. 
+  inversion_clear H1.
+  order.
+  generalize (Sort_Inf_In H2 H3 H4); order.
+  generalize (Sort_Inf_In H2 H3 H1); order.
+  inversion_clear H1.
+  order.
+  apply (H H2 _ _ H0 H4).
+  Qed.
+
+  Lemma remove_2 :
+   forall (s : t) (Hs : Sort s) (x y : elt),
+   ~ X.eq x y -> In y s -> In y (remove x s).
+  Proof.
+  simple induction s. 
+  simpl; intuition.
+  simpl; intros; case (X.compare x a); intuition; inversion_clear Hs;
+   inversion_clear H1; auto. 
+  destruct H0; apply X.eq_trans with a; auto.
+  Qed.
+
+  Lemma remove_3 :
+   forall (s : t) (Hs : Sort s) (x y : elt), In y (remove x s) -> In y s.
+  Proof.
+  simple induction s. 
+  simpl; intuition.
+  simpl; intros a l Hrec Hs x y; case (X.compare x a); intuition.
+  inversion_clear Hs; inversion_clear H; auto.
+  constructor 2; apply Hrec with x; auto.
+  Qed.
+  
+  Lemma singleton_sort : forall x : elt, Sort (singleton x).
+  Proof.
+  unfold singleton; simpl; auto.
+  Qed.
+
+  Lemma singleton_1 : forall x y : elt, In y (singleton x) -> X.eq x y.
+  Proof.
+  unfold singleton; simpl; intuition.
+  inversion_clear H; auto; inversion H0.
+  Qed. 
+
+  Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x).
+  Proof.
+  unfold singleton; simpl; auto.
+  Qed. 
+
+  Ltac DoubleInd :=
+    simple induction s;
+     [ simpl; auto; try solve [ intros; inversion H ]
+     | intros x l Hrec; simple induction s';
+        [ simpl; auto; try solve [ intros; inversion H ]
+        | intros x' l' Hrec' Hs Hs'; inversion Hs; inversion Hs'; subst;
+           simpl ] ].
+
+  Lemma union_Inf :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt),
+   Inf a s -> Inf a s' -> Inf a (union s s').
+  Proof.
+  DoubleInd.
+  intros i His His'; inversion_clear His; inversion_clear His'.
+  case (X.compare x x'); auto.
+  Qed.
+  Hint Resolve union_Inf.
+ 
+  Lemma union_sort :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (union s s').
+  Proof.
+  DoubleInd; case (X.compare x x'); intuition; constructor; auto.
+  apply Inf_eq with x'; trivial; apply union_Inf; trivial; apply Inf_eq with x; auto.
+  change (Inf x' (union (x :: l) l')); auto.
+  Qed.  
+  
+  Lemma union_1 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x (union s s') -> In x s \/ In x s'.
+  Proof.
+  DoubleInd; case (X.compare x x'); intuition; inversion_clear H; intuition.
+  elim (Hrec (x' :: l') H1 Hs' x0); intuition.
+  elim (Hrec l' H1 H5 x0); intuition.
+  elim (H0 x0); intuition.
+  Qed.
+
+  Lemma union_2 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x s -> In x (union s s').
+  Proof.
+  DoubleInd. 
+  intros i Hi; case (X.compare x x'); intuition; inversion_clear Hi; auto.
+  Qed.
+
+  Lemma union_3 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x s' -> In x (union s s').
+  Proof.
+  DoubleInd. 
+  intros i Hi; case (X.compare x x'); inversion_clear Hi; intuition.
+  constructor; apply X.eq_trans with x'; auto.  
+  Qed.
+    
+  Lemma inter_Inf :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt),
+   Inf a s -> Inf a s' -> Inf a (inter s s').
+  Proof.
+  DoubleInd.
+  intros i His His'; inversion His; inversion His'; subst.
+  case (X.compare x x'); intuition. 
+  apply Inf_lt with x; auto.
+  apply H3; auto.
+  apply Inf_lt with x'; auto.
+  Qed.
+  Hint Resolve inter_Inf. 
+
+  Lemma inter_sort :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (inter s s').
+  Proof.
+  DoubleInd; case (X.compare x x'); auto.
+  constructor; auto.
+  apply Inf_eq with x'; trivial; apply inter_Inf; trivial; apply Inf_eq with x; auto.
+  Qed.  
+  
+  Lemma inter_1 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x (inter s s') -> In x s.
+  Proof.
+  DoubleInd; case (X.compare x x'); intuition.
+  constructor 2; apply Hrec with (x'::l'); auto.
+  inversion_clear H; auto.
+  constructor 2; apply Hrec with l'; auto.
+  Qed.
+
+  Lemma inter_2 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x (inter s s') -> In x s'.
+  Proof.
+  DoubleInd; case (X.compare x x'); intuition; inversion_clear H.
+  constructor 1; apply X.eq_trans with x; auto.
+  constructor 2; auto.
+  Qed.
+
+  Lemma inter_3 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x s -> In x s' -> In x (inter s s').
+  Proof.
+  DoubleInd.
+  intros i His His'; elim (X.compare x x'); intuition.
+
+  inversion_clear His; auto.
+  generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) His'); order.
+
+  inversion_clear His; auto; inversion_clear His'; auto.
+  constructor; apply X.eq_trans with x'; auto.
+
+  change (In i (inter (x :: l) l')). 
+  inversion_clear His'; auto.
+  generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) His); order.
+  Qed.
+
+  Lemma diff_Inf :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt),
+   Inf a s -> Inf a s' -> Inf a (diff s s').
+  Proof.
+  DoubleInd.
+  intros i His His'; inversion His; inversion His'.
+  case (X.compare x x'); intuition.
+  apply Hrec; trivial.
+  apply Inf_lt with x; auto.
+  apply Inf_lt with x'; auto.
+  apply H10; trivial.
+  apply Inf_lt with x'; auto.
+  Qed.
+  Hint Resolve diff_Inf. 
+
+  Lemma diff_sort :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (diff s s').
+  Proof.
+  DoubleInd; case (X.compare x x'); auto.
+  Qed.  
+  
+  Lemma diff_1 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x (diff s s') -> In x s.
+  Proof.
+  DoubleInd; case (X.compare x x'); intuition.
+  inversion_clear H; auto.
+  constructor 2; apply Hrec with (x'::l'); auto.
+  constructor 2; apply Hrec with l'; auto.
+  Qed.
+
+  Lemma diff_2 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x (diff s s') -> ~ In x s'.
+  Proof.
+  DoubleInd.
+  intros; intro Abs; inversion Abs. 
+  case (X.compare x x'); intuition.
+
+  inversion_clear H.
+  generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) H3); order.
+  apply Hrec with (x'::l') x0; auto.
+  
+  inversion_clear H3.
+  generalize (Sort_Inf_In H1 H2 (diff_1 H1 H5 H)); order.
+  apply Hrec with l' x0; auto.
+  
+  inversion_clear H3. 
+  generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) (diff_1 Hs H5 H)); order.
+  apply H0 with x0; auto.
+  Qed.
+
+  Lemma diff_3 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt),
+   In x s -> ~ In x s' -> In x (diff s s').
+  Proof.
+  DoubleInd.
+  intros i His His'; elim (X.compare x x'); intuition; inversion_clear His; auto.
+  elim His'; constructor; apply X.eq_trans with x; auto.
+  Qed.  
+
+  Lemma equal_1 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'),
+   Equal s s' -> equal s s' = true.
+  Proof.
+  simple induction s; unfold Equal.
+  intro s'; case s'; auto.
+  simpl; intuition.
+  elim (H e); intros; assert (A : In e nil); auto; inversion A.
+  intros x l Hrec s'.
+  case s'.
+  intros; elim (H x); intros; assert (A : In x nil); auto; inversion A.
+  intros x' l' Hs Hs'; inversion Hs; inversion Hs'; subst.
+  simpl; case (X.compare x); intros; auto.
+
+  elim (H x); intros.
+  assert (A : In x (x' :: l')); auto; inversion_clear A.
+  order.
+  generalize (Sort_Inf_In H5 H6 H4); order.
+  
+  apply Hrec; intuition; elim (H a); intros.
+  assert (A : In a (x' :: l')); auto; inversion_clear A; auto.
+  generalize (Sort_Inf_In H1 H2 H0); order.
+  assert (A : In a (x :: l)); auto; inversion_clear A; auto.
+  generalize (Sort_Inf_In H5 H6 H0); order.
+
+  elim (H x'); intros.
+  assert (A : In x' (x :: l)); auto; inversion_clear A.
+  order.
+  generalize (Sort_Inf_In H1 H2 H4); order.
+  Qed.
+
+  Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'.
+  Proof.
+  simple induction s; unfold Equal.
+  intro s'; case s'; intros.
+  intuition.
+  simpl in H; discriminate H.
+  intros x l Hrec s'.
+  case s'.
+  intros; simpl in H; discriminate.
+  intros x' l'; simpl; case (X.compare x); intros; auto; try discriminate.
+  elim (Hrec l' H a); intuition; inversion_clear H2; auto.
+  constructor; apply X.eq_trans with x; auto.
+  constructor; apply X.eq_trans with x'; auto.
+  Qed.  
+  
+  Lemma subset_1 :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'),
+   Subset s s' -> subset s s' = true.
+  Proof.
+  intros s s'; generalize s' s; clear s s'.
+  simple induction s'; unfold Subset.
+  intro s; case s; auto.
+  intros; elim (H e); intros; assert (A : In e nil); auto; inversion A. 
+  intros x' l' Hrec s; case s.
+  simpl; auto.
+  intros x l Hs Hs'; inversion Hs; inversion Hs'; subst.
+  simpl; case (X.compare x); intros; auto.
+
+  assert (A : In x (x' :: l')); auto; inversion_clear A.
+  order.
+  generalize (Sort_Inf_In H5 H6 H0); order.
+  
+  apply Hrec; intuition.
+  assert (A : In a (x' :: l')); auto; inversion_clear A; auto.
+  generalize (Sort_Inf_In H1 H2 H0); order.
+
+  apply Hrec; intuition.
+  assert (A : In a (x' :: l')); auto; inversion_clear A; auto.
+  inversion_clear H0. 
+  order.
+  generalize (Sort_Inf_In H1 H2 H4); order.
+  Qed.
+
+  Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'.
+  Proof.
+  intros s s'; generalize s' s; clear s s'.
+  simple induction s'; unfold Subset.
+  intro s; case s; auto.
+  simpl; intros; discriminate H.
+  intros x' l' Hrec s; case s.
+  intros; inversion H0.
+  intros x l; simpl; case (X.compare x); intros; auto.
+  discriminate H.  
+  inversion_clear H0.
+  constructor; apply X.eq_trans with x; auto.
+  constructor 2; apply Hrec with l; auto.
+  constructor 2; apply Hrec with (x::l); auto.
+  Qed.  
+  
+  Lemma empty_sort : Sort empty.
+  Proof.
+  unfold empty; constructor.
+  Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof.
+  unfold Empty, empty; intuition; inversion H.
+  Qed. 
+
+  Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true.
+  Proof.
+  unfold Empty; intro s; case s; simpl; intuition.
+  elim (H e); auto.
+  Qed.
+  
+  Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. 
+  Proof.
+  unfold Empty; intro s; case s; simpl; intuition;
+   inversion H0.
+  Qed.
+
+  Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s).
+  Proof.
+  unfold elements; auto.
+  Qed.
+
+  Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s.
+  Proof. 
+  unfold elements; auto.
+  Qed.
+ 
+  Lemma elements_3 : forall (s : t) (Hs : Sort s), Sort (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.
+  Qed.  
+
+  Lemma min_elt_2 :
+   forall (s : t) (Hs : Sort s) (x y : elt),
+   min_elt s = Some x -> In y s -> ~ X.lt y x. 
+  Proof.
+  simple induction s; simpl.
+  intros; inversion H.
+  intros a l; case l; intros; inversion H0; inversion_clear H1; subst. 
+  order.
+  inversion H2.
+  order.
+  inversion_clear Hs.
+  inversion_clear H3.
+  generalize (H H1 e y (refl_equal (Some e)) H2); order.
+  Qed. 
+
+  Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s.
+  Proof.
+  unfold Empty; intro s; case s; simpl; intuition;
+   inversion H; inversion H0.
+  Qed.
+
+  Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. 
+  Proof. 
+  simple induction s; simpl.
+  intros; inversion H.
+  intros x l; case l; simpl.
+  intuition.
+  inversion H0; auto.
+  intros.
+  constructor 2; apply (H _ H0).
+  Qed.
+ 
+  Lemma max_elt_2 :
+   forall (s : t) (Hs : Sort s) (x y : elt),
+   max_elt s = Some x -> In y s -> ~ X.lt x y. 
+  Proof.
+  simple induction s; simpl.
+  intros; inversion H.
+  intros x l; case l; simpl.
+  intuition.
+  inversion H0; subst.
+  inversion_clear H1.
+  order.
+  inversion H3.
+  intros; inversion_clear Hs; inversion_clear H3; inversion_clear H1.
+  assert (In e (e::l0)) by auto.
+  generalize (H H2 x0 e H0 H1); order.
+  generalize (H H2 x0 y H0 H3); order.
+  Qed. 
+
+  Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s.
+  Proof.
+  unfold Empty; simple induction s; simpl.
+  red; intros; inversion H0.
+  intros x l; case l; simpl; intros.
+  inversion H0.
+  elim (H H0 e); auto.
+  Qed.
+
+  Definition choose_1 :
+    forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_1.
+
+  Definition choose_2 : forall s : t, choose s = None -> Empty s := min_elt_3.
+
+  Lemma fold_1 :
+   forall (s : t) (Hs : Sort s) (A : Set) (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; trivial.
+  intros.
+  inversion_clear Hs.
+  simpl; auto.
+  Qed.
+
+  Lemma cardinal_1 :
+   forall (s : t) (Hs : Sort s),
+   cardinal s = length (elements s).
+  Proof.
+  auto.
+  Qed.
+
+  Lemma filter_Inf :
+   forall (s : t) (Hs : Sort s) (x : elt) (f : elt -> bool),
+   Inf x s -> Inf x (filter f s).
+  Proof.
+  simple induction s; simpl.
+  intuition.  
+  intros x l Hrec Hs a f Ha; inversion_clear Hs; inversion_clear Ha.
+  case (f x). 
+  constructor; auto.
+  apply Hrec; auto.
+  apply Inf_lt with x; auto.
+  Qed.
+
+  Lemma filter_sort :
+   forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (filter f s).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec Hs f; inversion_clear Hs.
+  case (f x); auto.
+  constructor; auto.
+  apply filter_Inf; auto. 
+  Qed.
+
+  Lemma filter_1 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool X.eq f -> In x (filter f s) -> In x s.
+  Proof.
+  simple induction s; simpl.
+  intros; inversion H0.
+  intros x l Hrec a f Hf.
+  case (f x); simpl.
+  inversion_clear 1.
+  constructor; auto.
+  constructor 2; apply (Hrec a f Hf); trivial.
+  constructor 2; apply (Hrec a f Hf); trivial.
+  Qed.
+
+   Lemma filter_2 :
+    forall (s : t) (x : elt) (f : elt -> bool),
+    compat_bool X.eq f -> In x (filter f s) -> f x = true.   
+   Proof.
+  simple induction s; simpl.
+  intros; inversion H0.
+  intros x l Hrec a f Hf.
+  generalize (Hf x); case (f x); simpl; auto.
+  inversion_clear 2; auto.
+  symmetry; auto.
+  Qed.
+ 
+  Lemma filter_3 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s).     
+  Proof.
+  simple induction s; simpl.
+  intros; inversion H0.
+  intros x l Hrec a f Hf.
+  generalize (Hf x); case (f x); simpl.
+  inversion_clear 2; auto.
+  inversion_clear 2; auto.
+  rewrite <- (H a (X.eq_sym H1)); intros; discriminate.
+  Qed.
+
+  Lemma for_all_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f ->
+   For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof. 
+  simple induction s; simpl; auto; unfold For_all.
+  intros x l Hrec f Hf. 
+  generalize (Hf x); case (f x); simpl.
+  auto.
+  intros; rewrite (H x); auto.
+  Qed.
+
+  Lemma for_all_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f ->
+   for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof. 
+  simple induction s; simpl; auto; unfold For_all.
+  intros; inversion H1.
+  intros x l Hrec f Hf. 
+  intros A a; intros. 
+  assert (f x = true).
+   generalize A; case (f x); auto.
+  rewrite H0 in A; simpl in A.
+  inversion_clear H; auto.
+  rewrite (Hf a x); auto.
+  Qed.
+
+  Lemma exists_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof.
+  simple induction s; simpl; auto; unfold Exists.
+  intros.
+  elim H0; intuition. 
+  inversion H2.
+  intros x l Hrec f Hf. 
+  generalize (Hf x); case (f x); simpl.
+  auto.
+  destruct 2 as [a (A1,A2)].
+  inversion_clear A1.
+  rewrite <- (H a (X.eq_sym H0)) in A2; discriminate.
+  apply Hrec; auto.
+  exists a; auto.
+  Qed.
+
+  Lemma exists_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof. 
+  simple induction s; simpl; auto; unfold Exists.
+  intros; discriminate.
+  intros x l Hrec f Hf.
+  case_eq (f x); intros.
+  exists x; auto.
+  destruct (Hrec f Hf H0) as [a (A1,A2)].
+  exists a; auto.
+  Qed.
+
+  Lemma partition_Inf_1 :
+   forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt),
+   Inf x s -> Inf x (fst (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  intuition.  
+  intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha.
+  generalize (Hrec H f a).
+  case (f x); case (partition f l); simpl.
+  auto.
+  intros; apply H2; apply Inf_lt with x; auto.
+  Qed.
+
+  Lemma partition_Inf_2 :
+   forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt),
+   Inf x s -> Inf x (snd (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  intuition.  
+  intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha.
+  generalize (Hrec H f a).
+  case (f x); case (partition f l); simpl.
+  intros; apply H2; apply Inf_lt with x; auto.
+  auto.
+  Qed.
+
+  Lemma partition_sort_1 :
+   forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (fst (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec Hs f; inversion_clear Hs.
+  generalize (Hrec H f); generalize (partition_Inf_1 H f).
+  case (f x); case (partition f l); simpl; auto.
+  Qed.
+  
+  Lemma partition_sort_2 :
+   forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (snd (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec Hs f; inversion_clear Hs.
+  generalize (Hrec H f); generalize (partition_Inf_2 H f).
+  case (f x); case (partition f l); simpl; auto.
+  Qed.
+
+  Lemma partition_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f -> Equal (fst (partition f s)) (filter f s).
+  Proof.
+  simple induction s; simpl; auto; unfold Equal.
+  split; auto.
+  intros x l Hrec f Hf.
+  generalize (Hrec f Hf); clear Hrec.
+  destruct (partition f l) as [s1 s2]; simpl; intros.
+  case (f x); simpl; auto.
+  split; inversion_clear 1; auto.
+  constructor 2; rewrite <- H; auto.
+  constructor 2; rewrite H; auto.
+  Qed.
+   
+  Lemma partition_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f ->
+   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof.
+  simple induction s; simpl; auto; unfold Equal.
+  split; auto.
+  intros x l Hrec f Hf. 
+  generalize (Hrec f Hf); clear Hrec.
+  destruct (partition f l) as [s1 s2]; simpl; intros.
+  case (f x); simpl; auto.
+  split; inversion_clear 1; auto.
+  constructor 2; rewrite <- H; auto.
+  constructor 2; rewrite H; 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_sym : forall s s' : t, eq s s' -> eq s' s.
+  Proof. 
+  unfold eq, Equal; intros; destruct (H a); intuition.
+  Qed.
+
+  Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''.
+  Proof. 
+  unfold eq, Equal; intros; destruct (H a); destruct (H0 a); intuition.
+  Qed.
+
+  Inductive lt : t -> t -> Prop :=
+    | lt_nil : forall (x : elt) (s : t), lt nil (x :: s)
+    | lt_cons_lt :
+        forall (x y : elt) (s s' : t), X.lt x y -> lt (x :: s) (y :: s')
+    | lt_cons_eq :
+        forall (x y : elt) (s s' : t),
+        X.eq x y -> lt s s' -> lt (x :: s) (y :: s').
+  Hint Constructors lt.
+   
+  Lemma lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''.
+  Proof. 
+  intros s s' s'' H; generalize s''; clear s''; elim H.
+  intros x l s'' H'; inversion_clear H'; auto.
+  intros x x' l l' E s'' H'; inversion_clear H'; auto. 
+  constructor; apply X.lt_trans with x'; auto.
+  constructor; apply lt_eq with x'; auto.
+  intros.
+  inversion_clear H3.
+  constructor; apply eq_lt with y; auto.
+  constructor 3; auto; apply X.eq_trans with y; auto.  
+  Qed. 
+
+  Lemma lt_not_eq :
+   forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), lt s s' -> ~ eq s s'.
+  Proof. 
+  unfold eq, Equal. 
+  intros s s' Hs Hs' H; generalize Hs Hs'; clear Hs Hs'; elim H; intros; intro.
+  elim (H0 x); intros.
+  assert (X : In x nil); auto; inversion X.
+  inversion_clear Hs; inversion_clear Hs'.
+  elim (H1 x); intros. 
+  assert (X : In x (y :: s'0)); auto; inversion_clear X.
+  order.
+  generalize (Sort_Inf_In H4 H5 H8); order.
+  inversion_clear Hs; inversion_clear Hs'.
+  elim H2; auto; split; intros.
+  generalize (Sort_Inf_In H4 H5 H8); intros.
+  elim (H3 a); intros.
+  assert (X : In a (y :: s'0)); auto; inversion_clear X; auto.
+  order.
+  generalize (Sort_Inf_In H6 H7 H8); intros.
+  elim (H3 a); intros.
+  assert (X : In a (x :: s0)); auto; inversion_clear X; auto.
+  order.
+  Qed.
+
+  Definition compare :
+    forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Compare lt eq s s'.
+  Proof.
+  simple induction s.
+  intros; case s'. 
+  constructor 2; apply eq_refl. 
+  constructor 1; auto.
+  intros a l Hrec s'; case s'.
+  constructor 3; auto.
+  intros a' l' Hs Hs'.
+  case (X.compare a a'); [ constructor 1 | idtac | constructor 3 ]; auto.
+  elim (Hrec l');
+   [ constructor 1
+   | constructor 2
+   | constructor 3
+   | inversion Hs
+   | inversion Hs' ]; auto.
+  generalize e; unfold eq, Equal; intuition; inversion_clear H.
+  constructor; apply X.eq_trans with a; auto.
+  destruct (e1 a0); auto.
+  constructor; apply X.eq_trans with a'; auto.
+  destruct (e1 a0); auto.
+  Defined.
+
+End Raw.
+
+(** * Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we 
+   need to encapsulate everything into a type of strictly ordered lists. *)
+
+Module Make (X: OrderedType) <: S with Module E := X.
+
+ Module E := X.
+ Module Raw := Raw X. 
+
+ Record slist : Set :=  {this :> Raw.t; sorted : sort X.lt this}.
+ Definition t := slist. 
+ Definition elt := X.t.
+ 
+ Definition In (x : elt) (s : t) := InA X.eq x s.(this).
+ Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+ Definition Subset s s' := forall a : elt, In a s -> In a s'.
+ Definition Empty s := forall a : elt, ~ In a s.
+ Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+ Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+  
+ Definition In_1 (s : t) := Raw.MX.In_eq (l:=s.(this)).
+ 
+ Definition mem (x : elt) (s : t) := Raw.mem x s.
+ Definition mem_1 (s : t) := Raw.mem_1 (sorted s). 
+ Definition mem_2 (s : t) := Raw.mem_2 (s:=s).
+
+ Definition add x s := Build_slist (Raw.add_sort (sorted s) x).
+ Definition add_1 (s : t) := Raw.add_1 (sorted s).
+ Definition add_2 (s : t) := Raw.add_2 (sorted s).
+ Definition add_3 (s : t) := Raw.add_3 (sorted s).
+
+ Definition remove x s := Build_slist (Raw.remove_sort (sorted s) x).
+ Definition remove_1 (s : t) := Raw.remove_1 (sorted s).
+ Definition remove_2 (s : t) := Raw.remove_2 (sorted s).
+ Definition remove_3 (s : t) := Raw.remove_3 (sorted s).
+ 
+ Definition singleton x := Build_slist (Raw.singleton_sort x).
+ Definition singleton_1 := Raw.singleton_1.
+ Definition singleton_2 := Raw.singleton_2.
+  
+ Definition union (s s' : t) :=
+   Build_slist (Raw.union_sort (sorted s) (sorted s')). 
+ Definition union_1 (s s' : t) := Raw.union_1 (sorted s) (sorted s').
+ Definition union_2 (s s' : t) := Raw.union_2 (sorted s) (sorted s').
+ Definition union_3 (s s' : t) := Raw.union_3 (sorted s) (sorted s').
+
+ Definition inter (s s' : t) :=
+   Build_slist (Raw.inter_sort (sorted s) (sorted s')). 
+ Definition inter_1 (s s' : t) := Raw.inter_1 (sorted s) (sorted s').
+ Definition inter_2 (s s' : t) := Raw.inter_2 (sorted s) (sorted s').
+ Definition inter_3 (s s' : t) := Raw.inter_3 (sorted s) (sorted s').
+ 
+ Definition diff (s s' : t) :=
+   Build_slist (Raw.diff_sort (sorted s) (sorted s')). 
+ Definition diff_1 (s s' : t) := Raw.diff_1 (sorted s) (sorted s').
+ Definition diff_2 (s s' : t) := Raw.diff_2 (sorted s) (sorted s').
+ Definition diff_3 (s s' : t) := Raw.diff_3 (sorted s) (sorted s').
+ 
+ Definition equal (s s' : t) := Raw.equal s s'. 
+ Definition equal_1 (s s' : t) := Raw.equal_1 (sorted s) (sorted s').  
+ Definition equal_2 (s s' : t) := Raw.equal_2 (s:=s) (s':=s').
+ 
+ Definition subset (s s' : t) := Raw.subset s s'.
+ Definition subset_1 (s s' : t) := Raw.subset_1 (sorted s) (sorted s').  
+ Definition subset_2 (s s' : t) := Raw.subset_2 (s:=s) (s':=s').
+
+ Definition empty := Build_slist Raw.empty_sort.
+ Definition empty_1 := Raw.empty_1.
+ 
+ Definition is_empty (s : t) := Raw.is_empty s.
+ Definition is_empty_1 (s : t) := Raw.is_empty_1 (s:=s).
+ Definition is_empty_2 (s : t) := Raw.is_empty_2 (s:=s).
+
+ Definition elements (s : t) := Raw.elements s.
+ Definition elements_1 (s : t) := Raw.elements_1 (s:=s).
+ Definition elements_2 (s : t) := Raw.elements_2 (s:=s).
+ Definition elements_3 (s : t) := Raw.elements_3 (sorted s).
+ 
+ Definition min_elt (s : t) := Raw.min_elt s.
+ Definition min_elt_1 (s : t) := Raw.min_elt_1 (s:=s).
+ Definition min_elt_2 (s : t) := Raw.min_elt_2 (sorted s).
+ Definition min_elt_3 (s : t) := Raw.min_elt_3 (s:=s).
+
+ Definition max_elt (s : t) := Raw.max_elt s.
+ Definition max_elt_1 (s : t) := Raw.max_elt_1 (s:=s).
+ Definition max_elt_2 (s : t) := Raw.max_elt_2 (sorted s).
+ Definition max_elt_3 (s : t) := Raw.max_elt_3 (s:=s).
+  
+ Definition choose := min_elt.
+ Definition choose_1 := min_elt_1.
+ Definition choose_2 := min_elt_3.
+ 
+ Definition fold (B : Set) (f : elt -> B -> B) (s : t) := Raw.fold (B:=B) f s. 
+ Definition fold_1 (s : t) := Raw.fold_1 (sorted s). 
+ 
+ Definition cardinal (s : t) := Raw.cardinal s.
+ Definition cardinal_1 (s : t) := Raw.cardinal_1 (sorted s). 
+ 
+ Definition filter (f : elt -> bool) (s : t) :=
+   Build_slist (Raw.filter_sort (sorted s) f).
+ Definition filter_1 (s : t) := Raw.filter_1 (s:=s).
+ Definition filter_2 (s : t) := Raw.filter_2 (s:=s).
+ Definition filter_3 (s : t) := Raw.filter_3 (s:=s).
+ 
+ Definition for_all (f : elt -> bool) (s : t) := Raw.for_all f s.
+ Definition for_all_1 (s : t) := Raw.for_all_1 (s:=s). 
+ Definition for_all_2 (s : t) := Raw.for_all_2 (s:=s). 
+
+ Definition exists_ (f : elt -> bool) (s : t) := Raw.exists_ f s.
+ Definition exists_1 (s : t) := Raw.exists_1 (s:=s). 
+ Definition exists_2 (s : t) := Raw.exists_2 (s:=s). 
+
+ Definition partition (f : elt -> bool) (s : t) :=
+   let p := Raw.partition f s in
+   (Build_slist (this:=fst p) (Raw.partition_sort_1 (sorted s) f),
+   Build_slist (this:=snd p) (Raw.partition_sort_2 (sorted s) f)).
+ Definition partition_1 (s : t) := Raw.partition_1 s.
+ Definition partition_2 (s : t) := Raw.partition_2 s. 
+
+ Definition eq (s s' : t) := Raw.eq s s'.
+ Definition eq_refl (s : t) := Raw.eq_refl s.
+ Definition eq_sym (s s' : t) := Raw.eq_sym (s:=s) (s':=s').
+ Definition eq_trans (s s' s'' : t) :=
+   Raw.eq_trans (s:=s) (s':=s') (s'':=s'').
+  
+ Definition lt (s s' : t) := Raw.lt s s'.
+ Definition lt_trans (s s' s'' : t) :=
+   Raw.lt_trans (s:=s) (s':=s') (s'':=s'').
+ Definition lt_not_eq (s s' : t) := Raw.lt_not_eq (sorted s) (sorted s').
+
+ Definition compare : forall s s' : t, Compare lt eq s s'.
+ Proof.
+ intros; elim (Raw.compare (sorted s) (sorted s'));
+  [ constructor 1 | constructor 2 | constructor 3 ]; 
+  auto. 
+ Defined.
+
+End Make.
diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v
new file mode 100644
index 000000000..b67c1245e
--- /dev/null
+++ b/theories/FSets/FSetProperties.v
@@ -0,0 +1,1057 @@
+(***********************************************************************)
+(*  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: FSetProperties.v,v 1.16 2006/03/13 04:59:24 letouzey Exp $ *)
+
+(** * Finite sets library *)
+
+(** This functor derives additional properties from [FSetInterface.S].
+    Contrary to the functor in [FSetEqProperties] 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 FSetInterface. 
+Require Import FSetFacts.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Section Misc.
+Variable A B : Set.
+Variable eqA : A -> A -> Prop. 
+Variable eqB : B -> B -> Prop.
+
+(** Two-argument functions that allow to reorder its arguments. *)
+Definition transpose (f : A -> B -> B) :=
+  forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). 
+
+(** Compatibility of a two-argument function with respect to two equalities. *)
+Definition compat_op (f : A -> B -> B) :=
+  forall (x x' : A) (y y' : B), eqA x x' -> eqB y y' -> eqB (f x y) (f x' y').
+
+(** Compatibility of a function upon natural numbers. *)
+Definition compat_nat (f : A -> nat) :=
+  forall x x' : A, eqA x x' -> f x = f x'.
+
+End Misc.
+Hint Unfold transpose compat_op compat_nat.
+
+Hint Extern 1 (Setoid_Theory _ _) => constructor; congruence.
+
+Ltac trans_st x := match goal with 
+  | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
+     apply (Seq_trans _ _ H) with x; auto
+ end.
+
+Ltac sym_st := match goal with 
+  | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
+     apply (Seq_sym _ _ H); auto
+ end.
+
+Ltac refl_st := match goal with 
+  | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => 
+     apply (Seq_refl _ _ H); auto
+ end.
+
+Definition gen_st : forall A : Set, Setoid_Theory _ (@eq A).
+Proof. auto. Qed.
+
+Module Properties (M: S).
+  Module ME := OrderedTypeFacts M.E.  
+  Import ME.
+  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.
+  Variable s s' s'' s1 s2 s3 : t.
+  Variable x : elt.
+
+  (** properties of [Equal] *)
+
+  Lemma equal_refl : s[=]s.
+  Proof.
+  apply eq_refl.
+  Qed.
+
+  Lemma equal_sym : s[=]s' -> s'[=]s.
+  Proof.
+  apply eq_sym. 
+  Qed.
+
+  Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3.
+  Proof.
+  intros; apply eq_trans with s2; auto.
+  Qed.
+
+  (** 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.
+
+  (** 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.
+
+  (** 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 eq_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 eq_refl.
+  Qed.
+
+  Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''.
+  Proof.
+  intros; rewrite H; apply eq_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 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 eq_refl.
+  Qed.
+
+  Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''.
+  Proof.
+  intros; rewrite H; apply eq_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 : set.
+
+  Notation NoRedun := (noredunA E.eq).
+
+  Section noredunA_Remove.
+
+  Definition remove_list x l := MoreList.filter (fun y => negb (eqb x y)) l.
+
+  Lemma remove_list_correct :
+    forall s x, NoRedun s -> 
+    NoRedun (remove_list x s) /\
+    (forall y : elt, ME.In y (remove_list x s) <-> ME.In y s /\ ~ E.eq x y).
+  Proof.
+   simple induction s; simpl; intros.
+   repeat (split; trivial).
+   inversion H0.
+   destruct 1; inversion H0.
+   inversion_clear H0.
+   destruct (H x H2) as (H3,H4); clear H.
+   unfold eqb; destruct (eq_dec x a); simpl; trivial.  
+   split; auto; intros.
+   rewrite H4; clear H4.
+   split; destruct 1; split; auto.
+   inversion_clear H; auto; order.
+   split; auto; intros.
+   constructor; auto.
+   rewrite H4; intuition.
+   split.
+   inversion_clear 1.
+   split; auto; order.
+   rewrite (H4 y) in H0; destruct H0; auto.
+   destruct 1.
+   inversion_clear H; auto.
+   constructor 2; rewrite H4; auto.
+  Qed. 
+
+  Let ListEq l l' := forall y : elt, ME.In y l <-> ME.In y l'.
+
+  Lemma remove_list_equal :
+    forall s s' x, NoRedun (x :: s) -> NoRedun s' -> 
+    ListEq (x :: s) s' -> ListEq s (remove_list x s').
+  Proof.  
+   unfold ListEq; intros. 
+   inversion_clear H.
+   destruct (remove_list_correct x H0).
+   destruct (H4 y); clear H4.
+   destruct (H1 y); clear H1.
+   split; intros.
+   apply H6; split; auto. 
+   swap H2; apply In_eq with y; auto; order.
+   destruct (H5 H1); intros.
+   generalize (H7 H8); inversion_clear 1; auto.
+   destruct H9; auto.
+  Qed. 
+
+  Let ListAdd x l l' := forall y : elt, ME.In y l' <-> E.eq x y \/ ME.In y l.
+
+  Lemma remove_list_add :
+    forall s s' x x', NoRedun s -> NoRedun (x' :: s') ->
+    ~ E.eq x x' -> ~ ME.In x s -> 
+    ListAdd x s (x' :: s') -> ListAdd x (remove_list x' s) s'.
+  Proof.
+   unfold ListAdd; intros.
+   inversion_clear H0.
+   destruct (remove_list_correct x' H).
+   destruct (H6 y); clear H6.
+   destruct (H3 y); clear H3.
+   split; intros.
+   destruct H6; auto.
+   destruct (eq_dec x y); auto; intros.
+   right; apply H8; split; auto.
+   swap H4; apply In_eq with y; auto.
+   destruct H3.
+   assert (ME.In y (x' :: s')). auto.
+   inversion_clear H10; auto.
+   destruct H1; order.
+   destruct (H7 H3).
+   assert (ME.In y (x' :: s')). auto.
+   inversion_clear H12; auto.
+   destruct H11; auto. 
+  Qed.
+
+  Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA).
+  Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f).
+  Variables (i:A).
+
+  Lemma remove_list_fold_right_0 :
+    forall s x, NoRedun s -> ~ME.In x s ->
+    eqA (fold_right f i s) (fold_right f i (remove_list x s)).
+  Proof.
+   simple induction s; simpl; intros.
+   refl_st.
+   inversion_clear H0.
+   unfold eqb; destruct (eq_dec x a); simpl; intros.
+   absurd_hyp e; auto.
+   apply Comp; auto. 
+  Qed.   
+
+  Lemma remove_list_fold_right :
+    forall s x, NoRedun s -> ME.In x s ->
+    eqA (fold_right f i s) (f x (fold_right f i (remove_list x s))).
+  Proof.
+   simple induction s; simpl.  
+   inversion_clear 2.
+   intros.
+   inversion_clear H0.
+   unfold eqb; destruct (eq_dec x a); simpl; intros.
+   apply Comp; auto. 
+   apply remove_list_fold_right_0; auto.
+   swap H2; apply ME.In_eq with x; auto.
+   inversion_clear H1. 
+   destruct n; auto.
+   trans_st (f a (f x (fold_right f i (remove_list x l)))).
+  Qed.   
+
+  Lemma fold_right_equal :
+    forall s s', NoRedun s -> NoRedun s' ->
+    ListEq s s' -> eqA (fold_right f i s) (fold_right f i s').
+  Proof.
+   simple induction s.
+   destruct s'; simpl.
+   intros; refl_st; auto.
+   unfold ListEq; intros.
+   destruct (H1 t0).
+   assert (X : ME.In t0 nil); auto; inversion X.
+   intros x l Hrec s' N N' E; simpl in *.
+   trans_st (f x (fold_right f i (remove_list x s'))).
+   apply Comp; auto.
+   apply Hrec; auto.
+   inversion N; auto.
+   destruct (remove_list_correct x N'); auto.
+   apply remove_list_equal; auto.
+   sym_st.
+   apply remove_list_fold_right; auto.
+   unfold ListEq in E.
+   rewrite <- E; auto.
+  Qed.
+
+  Lemma fold_right_add :
+    forall s' s x, NoRedun s -> NoRedun s' -> ~ ME.In x s ->
+    ListAdd x s s' -> eqA (fold_right f i s') (f x (fold_right f i s)).
+  Proof.   
+   simple induction s'.
+   unfold ListAdd; intros.
+   destruct (H2 x); clear H2.
+   assert (X : ME.In x nil); auto; inversion X.
+   intros x' l' Hrec s x N N' IN EQ; simpl.
+   (* if x=x' *)
+   destruct (eq_dec x x').
+   apply Comp; auto.
+   apply fold_right_equal; auto.
+   inversion_clear N'; trivial.
+   unfold ListEq; unfold ListAdd in EQ; intros.
+   destruct (EQ y); clear EQ.
+   split; intros.
+   destruct H; auto.
+   inversion_clear N'.
+   destruct H2; apply In_eq with y; auto; order.
+   assert (X:ME.In y (x' :: l')); auto; inversion_clear X; auto.
+   destruct IN; apply In_eq with y; auto; order.
+   (* else x<>x' *)   
+   trans_st (f x' (f x (fold_right f i (remove_list x' s)))).
+   apply Comp; auto.
+   apply Hrec; auto.
+   destruct (remove_list_correct x' N); auto.
+   inversion_clear N'; auto.
+   destruct (remove_list_correct x' N).
+   rewrite H0; clear H0.
+   intuition.
+   apply remove_list_add; auto.
+   trans_st (f x (f x' (fold_right f i (remove_list x' s)))).
+   apply Comp; auto.
+   sym_st.
+   apply remove_list_fold_right; auto.
+   destruct (EQ x'). 
+   destruct H; auto; destruct n; auto.
+  Qed.
+
+  End noredunA_Remove.
+
+  (** * Alternative (weaker) specifications for [fold] *)
+
+  Section Old_Spec_Now_Properties. 
+
+  (** 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,
+        NoRedun 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 noredunA_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 := eqA); auto.
+  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,
+        noredunA 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 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_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/FSetWeak.v b/theories/FSets/FSetWeak.v
new file mode 100644
index 000000000..5fea8b6ea
--- /dev/null
+++ b/theories/FSets/FSetWeak.v
@@ -0,0 +1,13 @@
+(***********************************************************************)
+(*  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: FSet.v,v 1.2 2004/12/08 19:19:24 letouzey Exp $ *)
+
+Require Export DecidableType.
+Require Export FSetWeakInterface.
+Require Export FSetWeakList.
diff --git a/theories/FSets/FSetWeakInterface.v b/theories/FSets/FSetWeakInterface.v
new file mode 100644
index 000000000..adfa5f453
--- /dev/null
+++ b/theories/FSets/FSetWeakInterface.v
@@ -0,0 +1,244 @@
+(***********************************************************************)
+(*  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,v 1.4 2006/02/27 15:39:44 letouzey Exp $ *)
+
+(** * 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 *)
+ 
+  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' s'' : t.
+  Variable x y z : elt.
+
+  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.
+
+  (** 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).
+
+  (** 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.
+
+  (** Specification of [choose] *)
+  Parameter choose_1 : choose s = Some x -> In x s.
+  Parameter choose_2 : choose s = None -> Empty s.
+
+  End Filter.
+  End Spec.
+
+  Hint Immediate In_1.
+  
+  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.
+
+End S.
diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v
new file mode 100644
index 000000000..bcd966f9a
--- /dev/null
+++ b/theories/FSets/FSetWeakList.v
@@ -0,0 +1,873 @@
+(***********************************************************************)
+(*  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: FSetWeakList.v,v 1.8 2006/03/09 18:34:51 letouzey Exp $ *)
+
+(** * Finite sets library *)
+
+(** This file proposes an implementation of the non-dependant 
+    interface [FSetWeakInterface.S] using lists without redundancy. *)
+
+Require Import FSetWeakInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Functions over lists
+
+   First, we provide sets as lists which are (morally) without redundancy.
+   The specs are proved under the additional condition of no redundancy. 
+   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.
+
+  Definition empty : t := nil.
+
+  Definition is_empty (l : t) : bool := if l then true else false.
+
+  (** ** The set operations. *)
+
+  Fixpoint mem (x : elt) (s : t) {struct s} : bool :=
+    match s with
+    | nil => false
+    | y :: l =>
+           if X.eq_dec x y then true else mem x l
+    end.
+
+  Fixpoint add (x : elt) (s : t) {struct s} : t :=
+    match s with
+    | nil => x :: nil
+    | y :: l =>
+        if X.eq_dec x y then s else y :: add x l
+    end.
+
+  Definition singleton (x : elt) : t := x :: nil. 
+
+  Fixpoint remove (x : elt) (s : t) {struct s} : t :=
+    match s with
+    | nil => nil
+    | y :: l =>
+        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} : 
+   B -> B := fun i => match s with
+                      | nil => i
+                      | x :: l => fold f l (f x i)
+                      end.  
+
+  Definition union (s : t) : t -> t := fold add s.
+  
+  Definition diff (s s' : t) : t := fold remove s' s.
+
+  Definition inter (s s': t) : t := 
+    fold (fun x s => if mem x s' then add x s else s) s nil.
+
+  Definition subset (s s' : t) : bool := is_empty (diff s s').
+
+  Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s). 
+
+  Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t :=
+    match s with
+    | nil => nil
+    | x :: l => if f x then x :: filter f l else filter f l
+    end.  
+
+  Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool :=
+    match s with
+    | nil => true
+    | x :: l => if f x then for_all f l else false
+    end.  
+ 
+  Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool :=
+    match s with
+    | nil => false
+    | x :: l => if f x then true else exists_ f l
+    end.
+
+  Fixpoint partition (f : elt -> bool) (s : t) {struct s} : 
+   t * t :=
+    match s with
+    | nil => (nil, nil)
+    | x :: l =>
+        let (s1, s2) := partition f l in
+        if f x then (x :: s1, s2) else (s1, x :: s2)
+    end.
+
+  Definition cardinal (s : t) : nat := length s.
+
+  Definition elements (s : t) : list elt := s.
+
+  Definition choose (s : t) : option elt := 
+     match s with 
+      | nil => None
+      | x::_ => Some x
+     end.
+
+  (** ** Proofs of set operation specifications. *)
+
+  Notation NoRedun := (noredunA X.eq).
+  Notation In := (InA X.eq).
+
+  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.
+
+  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.
+  Qed.
+  Hint Immediate In_eq.
+
+  Lemma mem_1 :
+   forall (s : t)(x : elt), In x s -> mem x s = true. 
+  Proof.
+  induction s; intros.
+  inversion H.
+  simpl; destruct (X.eq_dec x a); trivial.
+  inversion_clear H; auto.
+  Qed.
+
+  Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
+  Proof.
+  induction s. 
+  intros; inversion H.
+  intros x; simpl.
+  destruct (X.eq_dec x a); firstorder; discriminate.
+  Qed.
+
+  Lemma add_1 :
+   forall (s : t) (Hs : NoRedun s) (x y : elt), X.eq x y -> In y (add x s).
+  Proof.
+  induction s. 
+  simpl; intuition.
+  simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs;
+   firstorder.
+  eauto.
+  Qed.
+
+  Lemma add_2 :
+   forall (s : t) (Hs : NoRedun s) (x y : elt), In y s -> In y (add x s).
+  Proof.
+  induction s. 
+  simpl; intuition.
+  simpl; intros; case (X.eq_dec x a); intuition.
+  inversion_clear Hs; eauto; inversion_clear H; intuition.
+  Qed.
+
+  Lemma add_3 :
+   forall (s : t) (Hs : NoRedun s) (x y : elt),
+   ~ X.eq x y -> In y (add x s) -> In y s.
+  Proof.
+  induction s. 
+  simpl; intuition.
+  inversion_clear H0; firstorder; absurd (X.eq x y); auto.
+  simpl; intros Hs x y; case (X.eq_dec x a); intros;
+   inversion_clear H0; inversion_clear Hs; firstorder; 
+   absurd (X.eq x y); auto.
+  Qed.
+
+  Lemma add_unique :
+   forall (s : t) (Hs : NoRedun s)(x:elt), NoRedun (add x s).
+  Proof.
+  induction s.  
+  simpl; intuition.
+  constructor; auto.
+  intro H0; inversion H0.
+  intros.
+  inversion_clear Hs.
+  simpl.
+  destruct (X.eq_dec x a).
+  constructor; auto.
+  constructor; auto.
+  intro H1; apply H.
+  eapply add_3; eauto.
+  Qed.
+
+  Lemma remove_1 :
+   forall (s : t) (Hs : NoRedun s) (x y : elt), X.eq x y -> ~ In y (remove x s).
+  Proof.
+  simple induction s. 
+  simpl; red; intros; inversion H0.
+  simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs. 
+  elim H2.
+  apply In_eq with y; eauto.
+  inversion_clear H1; eauto.
+  Qed.
+
+  Lemma remove_2 :
+   forall (s : t) (Hs : NoRedun s) (x y : elt),
+   ~ X.eq x y -> In y s -> In y (remove x s).
+  Proof.
+  simple induction s. 
+  simpl; intuition.
+  simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs;
+   inversion_clear H1; auto. 
+  absurd (X.eq x y); eauto. 
+  Qed.
+
+  Lemma remove_3 :
+   forall (s : t) (Hs : NoRedun s) (x y : elt), In y (remove x s) -> In y s.
+  Proof.
+  simple induction s. 
+  simpl; intuition.
+  simpl; intros a l Hrec Hs x y; case (X.eq_dec x a); intuition.
+  inversion_clear Hs; inversion_clear H; firstorder.
+  Qed.
+
+  Lemma remove_unique :
+   forall (s : t) (Hs : NoRedun s) (x : elt), NoRedun (remove x s).
+  Proof.
+  simple induction s.
+  simpl; intuition.
+  simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs;
+   auto.
+  constructor; auto.
+  intro H2; elim H0.
+  eapply remove_3; eauto.
+  Qed. 
+
+  Lemma singleton_unique : forall x : elt, NoRedun (singleton x).
+  Proof.
+  unfold singleton; simpl; constructor; auto; intro H; inversion H.
+  Qed.
+
+  Lemma singleton_1 : forall x y : elt, In y (singleton x) -> X.eq x y.
+  Proof.
+  unfold singleton; simpl; intuition.
+  inversion_clear H; auto; inversion H0.
+  Qed. 
+
+  Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x).
+  Proof.
+  unfold singleton; simpl; intuition.
+  Qed. 
+  
+  Lemma empty_unique : NoRedun empty.
+  Proof.
+  unfold empty; constructor.
+  Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof.
+  unfold Empty, empty; intuition; inversion H.
+  Qed. 
+
+  Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true.
+  Proof.
+  unfold Empty; intro s; case s; simpl; intuition.
+  elim (H e); auto.
+  Qed.
+  
+  Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. 
+  Proof.
+  unfold Empty; intro s; case s; simpl; intuition;
+   inversion H0.
+  Qed.
+
+  Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s).
+  Proof.
+  unfold elements; auto.
+  Qed.
+
+  Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s.
+  Proof. 
+  unfold elements; auto.
+  Qed.
+ 
+  Lemma elements_3 : forall (s : t) (Hs : NoRedun s), NoRedun (elements s).  
+  Proof. 
+  unfold elements; auto.
+  Qed.
+
+  Lemma fold_1 :
+   forall (s : t) (Hs : NoRedun s) (A : Set) (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.
+  inversion_clear Hs; auto.
+  Qed.
+
+  Lemma union_unique :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s'), NoRedun (union s s').
+  Proof.
+  unfold union; induction s; simpl; auto; intros.
+  inversion_clear Hs.
+  apply IHs; auto.
+  apply add_unique; auto.
+  Qed.
+  
+  Lemma union_1 :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s') (x : elt),
+   In x (union s s') -> In x s \/ In x s'.
+  Proof.
+  unfold union; induction s; simpl; auto; intros.
+  inversion_clear Hs.
+  destruct (X.eq_dec x a).
+  left; auto.
+  destruct (IHs (add a s') H1 (add_unique Hs' a) x); intuition.
+  right; eapply add_3; eauto.
+  Qed.
+
+  Lemma union_0 : 
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s') (x : elt),
+   In x s \/ In x s' -> In x (union s s').
+  Proof.
+  unfold union; induction s; simpl; auto; intros.
+  inversion_clear H; auto.
+  inversion_clear H0.
+  inversion_clear Hs.
+  apply IHs; auto.
+  apply add_unique; auto.
+  destruct H.
+  inversion_clear H; auto.
+  right; apply add_1; auto.
+  right; apply add_2; auto.
+  Qed.
+
+  Lemma union_2 :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s') (x : elt),
+   In x s -> In x (union s s').
+  Proof.
+  intros; apply union_0; auto.
+  Qed.
+
+  Lemma union_3 :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s') (x : elt),
+   In x s' -> In x (union s s').
+  Proof.
+  intros; apply union_0; auto.
+  Qed.
+
+  Lemma inter_unique :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s'), NoRedun (inter s s').
+  Proof.
+  unfold inter; intros s.
+  set (acc := nil (A:=elt)).
+  assert (NoRedun acc) by (unfold acc; auto).
+  clearbody acc; generalize H; clear H; generalize acc; clear acc. 
+  induction s; simpl; auto; intros.
+  inversion_clear Hs.
+  apply IHs; auto.
+  destruct (mem a s'); intros; auto.
+  apply add_unique; auto.
+  Qed.  
+  
+  Lemma inter_0  :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s') (x : elt),
+   In x (inter s s') -> In x s /\ In x s'.
+  Proof.
+  unfold inter; intros.
+  set (acc := nil (A:=elt)) in *.
+  assert (NoRedun acc) by (unfold acc; auto).
+  cut ((In x s /\ In x s') \/ In x acc).
+    destruct 1; auto.
+    inversion H1.
+  clearbody acc. 
+  generalize H0 H Hs' Hs; clear H0 H Hs Hs'.
+  generalize acc x s'; clear acc x s'.
+  induction s; simpl; auto; intros.
+  inversion_clear Hs.
+  case_eq (mem a s'); intros H3; rewrite H3 in H; simpl in H.
+  destruct (IHs _ _ _ (add_unique H0 a) H); auto.
+  left; intuition.
+  destruct (X.eq_dec x a); auto.
+  left; intuition.
+  apply In_eq with a; eauto.
+  apply mem_2; auto.
+  right; eapply add_3; eauto.
+  destruct (IHs _ _ _ H0 H); auto.
+  left; intuition.
+  Qed.
+
+  Lemma inter_1  :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s') (x : elt),
+   In x (inter s s') -> In x s.
+  Proof.
+  intros; cut (In x s /\ In x s'); [ intuition | apply inter_0; auto ].
+  Qed.
+
+  Lemma inter_2 :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s') (x : elt),
+   In x (inter s s') -> In x s'.
+  Proof.
+  intros; cut (In x s /\ In x s'); [ intuition | apply inter_0; auto ].
+  Qed.
+
+  Lemma inter_3 :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s') (x : elt),
+   In x s -> In x s' -> In x (inter s s').
+  Proof.
+  intros s s' Hs Hs' x.
+  cut (((In x s /\ In x s')\/ In x (nil (A:=elt))) -> In x (inter s s')).
+  intuition.
+  unfold inter.
+  set (acc := nil (A:=elt)) in *.
+  assert (NoRedun acc) by (unfold acc; auto).
+  clearbody acc. 
+  generalize H Hs' Hs; clear H Hs Hs'.
+  generalize acc x s'; clear acc x s'.
+  induction s; simpl; auto; intros.
+  destruct H0; auto.
+  destruct H0; inversion H0.
+  inversion_clear Hs.
+  case_eq (mem a s'); intros H3; apply IHs; auto.
+  apply add_unique; auto.
+  destruct H0.
+  destruct H0.
+  inversion_clear H0.
+  right; apply add_1; auto.
+  left; auto.
+  right; apply add_2; auto.
+  destruct H0; auto.
+  destruct H0.
+  inversion_clear H0; auto.
+  absurd (In x s'); auto.
+  red; intros.
+  rewrite (mem_1 (In_eq H5 H0)) in H3.
+  discriminate.
+  Qed.
+
+  Lemma diff_unique :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s'), NoRedun (diff s s').
+  Proof.
+  unfold diff; intros s s' Hs; generalize s Hs; clear Hs s.
+  induction s'; simpl; auto; intros.
+  inversion_clear Hs'.
+  apply IHs'; auto.
+  apply remove_unique; auto.
+  Qed.  
+  
+  Lemma diff_0 :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s') (x : elt),
+   In x (diff s s') -> In x s /\ ~ In x s'.
+  Proof.
+  unfold diff; intros s s' Hs; generalize s Hs; clear Hs s.
+  induction s'; simpl; auto; intros.
+  inversion_clear Hs'.
+  split; auto; intro H1; inversion H1.
+  inversion_clear Hs'.
+  destruct (IHs' (remove a s) (remove_unique Hs a) H1 x H).
+  split. 
+  eapply remove_3; eauto.
+  red; intros.
+  inversion_clear H4; auto.
+  destruct (remove_1 Hs (X.eq_sym H5) H2).
+  Qed.
+
+  Lemma diff_1 :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s') (x : elt),
+   In x (diff s s') -> In x s.
+  Proof.
+  intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. 
+  Qed.
+
+  Lemma diff_2 :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s') (x : elt),
+   In x (diff s s') -> ~ In x s'.
+  Proof.
+  intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. 
+  Qed.
+
+  Lemma diff_3 :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s') (x : elt),
+   In x s -> ~ In x s' -> In x (diff s s').
+  Proof.
+  unfold diff; intros s s' Hs; generalize s Hs; clear Hs s.
+  induction s'; simpl; auto; intros.
+  inversion_clear Hs'.
+  apply IHs'; auto.
+  apply remove_unique; auto.
+  apply remove_2; auto.
+  Qed.  
+  
+  Lemma subset_1 :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s'),
+   Subset s s' -> subset s s' = true.
+  Proof.
+  unfold subset, Subset; intros.
+  apply is_empty_1.
+  unfold Empty; intros.
+  intro.
+  destruct (diff_2 Hs Hs' H0).
+  apply H.
+  eapply diff_1; eauto.
+  Qed.
+
+  Lemma subset_2 : forall (s s' : t)(Hs : NoRedun s) (Hs' : NoRedun s'), 
+     subset s s' = true -> Subset s s'.
+  Proof.
+  unfold subset, Subset; intros.
+  generalize (is_empty_2 H); clear H; unfold Empty; intros.
+  generalize (@mem_1 s' a) (@mem_2 s' a); destruct (mem a s').
+  intuition.
+  intros.
+  destruct (H a).
+  apply diff_3; intuition.
+  Qed.
+
+  Lemma equal_1 :
+   forall (s s' : t) (Hs : NoRedun s) (Hs' : NoRedun s'),
+   Equal s s' -> equal s s' = true.
+  Proof.
+  unfold Equal, equal; intros.
+  apply andb_true_intro; split; apply subset_1; firstorder.
+  Qed.
+
+  Lemma equal_2 : forall (s s' : t)(Hs : NoRedun s) (Hs' : NoRedun s'),  
+     equal s s' = true -> Equal s s'.
+  Proof.
+  unfold Equal, equal; intros.
+  destruct (andb_prop _ _ H); clear H.
+  split; apply subset_2; auto.
+  Qed.  
+
+  Definition choose_1 :
+    forall (s : t) (x : elt), choose s = Some x -> In x s.
+  Proof.
+  destruct s; simpl; intros; inversion H; auto.
+  Qed.  
+
+  Definition choose_2 : forall s : t, choose s = None -> Empty s.
+  Proof.
+  destruct s; simpl; intros.
+  intros x H0; inversion H0.
+  inversion H.
+  Qed.  
+
+  Lemma cardinal_1 :
+   forall (s : t) (Hs : NoRedun s), cardinal s = length (elements s).
+  Proof.
+  auto.
+  Qed.
+
+  Lemma filter_1 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   In x (filter f s) -> In x s.
+  Proof.
+  simple induction s; simpl.
+  intros; inversion H.
+  intros x l Hrec a f.
+  case (f x); simpl.
+  inversion_clear 1.
+  constructor; auto.
+  constructor 2; apply (Hrec a f); trivial.
+  constructor 2; apply (Hrec a f); trivial.
+  Qed.
+
+   Lemma filter_2 :
+    forall (s : t) (x : elt) (f : elt -> bool),
+    compat_bool X.eq f -> In x (filter f s) -> f x = true.   
+   Proof.
+  simple induction s; simpl.
+  intros; inversion H0.
+  intros x l Hrec a f Hf.
+  generalize (Hf x); case (f x); simpl; auto.
+  inversion_clear 2; auto.
+  symmetry; auto.
+  Qed.
+ 
+  Lemma filter_3 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s).     
+  Proof.
+  simple induction s; simpl.
+  intros; inversion H0.
+  intros x l Hrec a f Hf.
+  generalize (Hf x); case (f x); simpl.
+  inversion_clear 2; auto.
+  inversion_clear 2; auto.
+  rewrite <- (H a (X.eq_sym H1)); intros; discriminate.
+  Qed.
+
+  Lemma filter_unique :
+   forall (s : t) (Hs : NoRedun s) (f : elt -> bool), NoRedun (filter f s).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec Hs f; inversion_clear Hs.
+  case (f x); auto.
+  constructor; auto.
+  intro H1; apply H.
+  eapply filter_1; eauto.
+  Qed.
+
+
+  Lemma for_all_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f ->
+   For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof. 
+  simple induction s; simpl; auto; unfold For_all.
+  intros x l Hrec f Hf. 
+  generalize (Hf x); case (f x); simpl.
+  auto.
+  intros; rewrite (H x); auto.
+  Qed.
+
+  Lemma for_all_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f ->
+   for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof. 
+  simple induction s; simpl; auto; unfold For_all.
+  intros; inversion H1.
+  intros x l Hrec f Hf. 
+  intros A a; intros. 
+  assert (f x = true).
+   generalize A; case (f x); auto.
+  rewrite H0 in A; simpl in A.
+  inversion_clear H; auto.
+  rewrite (Hf a x); auto.
+  Qed.
+
+  Lemma exists_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof.
+  simple induction s; simpl; auto; unfold Exists.
+  intros.
+  elim H0; intuition. 
+  inversion H2.
+  intros x l Hrec f Hf. 
+  generalize (Hf x); case (f x); simpl.
+  auto.
+  destruct 2 as [a (A1,A2)].
+  inversion_clear A1.
+  rewrite <- (H a (X.eq_sym H0)) in A2; discriminate.
+  apply Hrec; auto.
+  exists a; auto.
+  Qed.
+
+  Lemma exists_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof. 
+  simple induction s; simpl; auto; unfold Exists.
+  intros; discriminate.
+  intros x l Hrec f Hf.
+  case_eq (f x); intros.
+  exists x; auto.
+  destruct (Hrec f Hf H0) as [a (A1,A2)].
+  exists a; auto.
+  Qed.
+
+  Lemma partition_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f -> Equal (fst (partition f s)) (filter f s).
+  Proof.
+  simple induction s; simpl; auto; unfold Equal.
+  firstorder.
+  intros x l Hrec f Hf.
+  generalize (Hrec f Hf); clear Hrec.
+  case (partition f l); intros s1 s2; simpl; intros.
+  case (f x); simpl; firstorder; inversion H0; intros; firstorder. 
+  Qed.
+   
+  Lemma partition_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool X.eq f ->
+   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof.
+  simple induction s; simpl; auto; unfold Equal.
+  firstorder.
+  intros x l Hrec f Hf. 
+  generalize (Hrec f Hf); clear Hrec.
+  case (partition f l); intros s1 s2; simpl; intros.
+  case (f x); simpl; firstorder; inversion H0; intros; firstorder. 
+  Qed.
+
+  Lemma partition_aux_1 : 
+   forall (s : t) (Hs : NoRedun s) (f : elt -> bool)(x:elt), 
+    In x (fst (partition f s)) -> In x s.
+  Proof.
+  induction s; simpl; auto; intros.
+  inversion_clear Hs.
+  generalize (IHs H1 f x).
+  destruct (f a); destruct (partition f s); simpl in *; auto.
+  inversion_clear H; auto.
+  Qed. 
+     
+  Lemma partition_aux_2 : 
+   forall (s : t) (Hs : NoRedun s) (f : elt -> bool)(x:elt), 
+    In x (snd (partition f s)) -> In x s.
+  Proof.
+  induction s; simpl; auto; intros.
+  inversion_clear Hs.
+  generalize (IHs H1 f x).
+  destruct (f a); destruct (partition f s); simpl in *; auto.
+  inversion_clear H; auto.
+  Qed. 
+  
+  Lemma partition_unique_1 :
+   forall (s : t) (Hs : NoRedun s) (f : elt -> bool), NoRedun (fst (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec Hs f; inversion_clear Hs.
+  generalize (@partition_aux_1 _ H0 f x).
+  generalize (Hrec H0 f).
+  case (f x); case (partition f l); simpl; auto.
+  Qed.
+  
+  Lemma partition_unique_2 :
+   forall (s : t) (Hs : NoRedun s) (f : elt -> bool), NoRedun (snd (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec Hs f; inversion_clear Hs.
+  generalize (@partition_aux_2 _ H0 f x).
+  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_sym : forall s s' : t, eq s s' -> eq s' s.
+  Proof. 
+  unfold eq, Equal; firstorder.
+  Qed.
+
+  Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''.
+  Proof. 
+  unfold eq, Equal; firstorder.
+  Qed.
+
+End Raw.
+
+(** * Encapsulation
+
+   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 E := X.
+ Module Raw := Raw X. 
+
+ Record slist : Set :=  {this :> Raw.t; unique : noredunA X.eq this}.
+ Definition t := slist. 
+ Definition elt := X.t.
+ 
+ Definition In (x : elt) (s : t) := InA X.eq x s.(this).
+ Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+ Definition Subset s s' := forall a : elt, In a s -> In a s'.
+ Definition Empty s := forall a : elt, ~ In a s.
+ Definition For_all (P : elt -> Prop) (s : t) :=
+   forall x : elt, In x s -> P x.
+ Definition Exists (P : elt -> Prop) (s : t) := exists x : elt, In x s /\ P x.
+  
+ Definition In_1 (s : t) := Raw.In_eq (s:=s).
+ 
+ Definition mem (x : elt) (s : t) := Raw.mem x s.
+ Definition mem_1 (s : t) := Raw.mem_1 (s:=s). 
+ Definition mem_2 (s : t) := Raw.mem_2 (s:=s).
+
+ Definition add x s := Build_slist (Raw.add_unique (unique s) x).
+ Definition add_1 (s : t) := Raw.add_1 (unique s).
+ Definition add_2 (s : t) := Raw.add_2 (unique s).
+ Definition add_3 (s : t) := Raw.add_3 (unique s).
+
+ Definition remove x s := Build_slist (Raw.remove_unique (unique s) x).
+ Definition remove_1 (s : t) := Raw.remove_1 (unique s).
+ Definition remove_2 (s : t) := Raw.remove_2 (unique s).
+ Definition remove_3 (s : t) := Raw.remove_3 (unique s).
+ 
+ Definition singleton x := Build_slist (Raw.singleton_unique x).
+ Definition singleton_1 := Raw.singleton_1.
+ Definition singleton_2 := Raw.singleton_2.
+  
+ Definition union (s s' : t) :=
+   Build_slist (Raw.union_unique (unique s) (unique s')). 
+ Definition union_1 (s s' : t) := Raw.union_1 (unique s) (unique s').
+ Definition union_2 (s s' : t) := Raw.union_2 (unique s) (unique s').
+ Definition union_3 (s s' : t) := Raw.union_3 (unique s) (unique s').
+
+ Definition inter (s s' : t) :=
+   Build_slist (Raw.inter_unique (unique s) (unique s')). 
+ Definition inter_1 (s s' : t) := Raw.inter_1 (unique s) (unique s').
+ Definition inter_2 (s s' : t) := Raw.inter_2 (unique s) (unique s').
+ Definition inter_3 (s s' : t) := Raw.inter_3 (unique s) (unique s').
+ 
+ Definition diff (s s' : t) :=
+   Build_slist (Raw.diff_unique (unique s) (unique s')). 
+ Definition diff_1 (s s' : t) := Raw.diff_1 (unique s) (unique s').
+ Definition diff_2 (s s' : t) := Raw.diff_2 (unique s) (unique s').
+ Definition diff_3 (s s' : t) := Raw.diff_3 (unique s) (unique s').
+ 
+ Definition equal (s s' : t) := Raw.equal s s'. 
+ Definition equal_1 (s s' : t) := Raw.equal_1 (unique s) (unique s').  
+ Definition equal_2 (s s' : t) := Raw.equal_2 (unique s) (unique s').
+ 
+ Definition subset (s s' : t) := Raw.subset s s'.
+ Definition subset_1 (s s' : t) := Raw.subset_1 (unique s) (unique s').  
+ Definition subset_2 (s s' : t) := Raw.subset_2 (unique s) (unique s').
+
+ Definition empty := Build_slist Raw.empty_unique.
+ Definition empty_1 := Raw.empty_1.
+ 
+ Definition is_empty (s : t) := Raw.is_empty s.
+ Definition is_empty_1 (s : t) := Raw.is_empty_1 (s:=s).
+ Definition is_empty_2 (s : t) := Raw.is_empty_2 (s:=s).
+
+ Definition elements (s : t) := Raw.elements s.
+ Definition elements_1 (s : t) := Raw.elements_1 (s:=s).
+ Definition elements_2 (s : t) := Raw.elements_2 (s:=s).
+ Definition elements_3 (s : t) := Raw.elements_3 (unique s).
+  
+ Definition choose (s:t) := Raw.choose s.
+ Definition choose_1 (s : t) := Raw.choose_1 (s:=s).
+ Definition choose_2 (s : t) := Raw.choose_2 (s:=s).
+  
+ Definition fold (B : Set) (f : elt -> B -> B) (s : t) := Raw.fold (B:=B) f s. 
+ Definition fold_1 (s : t) := Raw.fold_1 (unique s). 
+ 
+ Definition cardinal (s : t) := Raw.cardinal s.
+ Definition cardinal_1 (s : t) := Raw.cardinal_1 (unique s). 
+ 
+ Definition filter (f : elt -> bool) (s : t) :=
+   Build_slist (Raw.filter_unique (unique s) f).
+ Definition filter_1 (s : t)(x:elt)(f: elt -> bool)(H:compat_bool X.eq f) := 
+    @Raw.filter_1 s x f.
+ Definition filter_2 (s : t) := Raw.filter_2 (s:=s).
+ Definition filter_3 (s : t) := Raw.filter_3 (s:=s).
+ 
+ Definition for_all (f : elt -> bool) (s : t) := Raw.for_all f s.
+ Definition for_all_1 (s : t) := Raw.for_all_1 (s:=s). 
+ Definition for_all_2 (s : t) := Raw.for_all_2 (s:=s). 
+
+ Definition exists_ (f : elt -> bool) (s : t) := Raw.exists_ f s.
+ Definition exists_1 (s : t) := Raw.exists_1 (s:=s). 
+ Definition exists_2 (s : t) := Raw.exists_2 (s:=s). 
+
+ Definition partition (f : elt -> bool) (s : t) :=
+   let p := Raw.partition f s in
+   (Build_slist (this:=fst p) (Raw.partition_unique_1 (unique s) f),
+   Build_slist (this:=snd p) (Raw.partition_unique_2 (unique s) f)).
+ Definition partition_1 (s : t) := Raw.partition_1 s.
+ Definition partition_2 (s : t) := Raw.partition_2 s. 
+
+ Definition eq (s s' : t) := Raw.eq s s'.
+ Definition eq_refl (s : t) := Raw.eq_refl s.
+ Definition eq_sym (s s' : t) := Raw.eq_sym (s:=s) (s':=s').
+ Definition eq_trans (s s' s'' : t) :=
+   Raw.eq_trans (s:=s) (s':=s') (s'':=s'').
+
+End Make.
diff --git a/theories/FSets/OrderedType.v b/theories/FSets/OrderedType.v
new file mode 100644
index 000000000..c5edf1de4
--- /dev/null
+++ b/theories/FSets/OrderedType.v
@@ -0,0 +1,566 @@
+(***********************************************************************)
+(*  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: OrderedType.v,v 1.4 2006/03/10 10:49:48 letouzey Exp $ *)
+
+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 :=
+  | 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 eq : t -> t -> Prop.
+  Parameter 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.
+  Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z.
+ 
+  Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z.
+  Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y.
+
+  Parameter compare : forall x y : t, Compare lt eq x y.
+
+  Hint Immediate eq_sym.
+  Hint Resolve eq_refl eq_trans lt_not_eq lt_trans.
+
+End OrderedType.
+
+(** * Ordered types properties *)
+
+(** Additional properties that can be derived from signature
+    [OrderedType]. *)
+
+Module OrderedTypeFacts (O: OrderedType). 
+  Import O.
+
+  Lemma lt_antirefl : forall x, ~ lt x x.
+  Proof.
+   intros; intro; absurd (eq x x); auto. 
+  Qed.
+
+  Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z.
+  Proof. 
+   intros; destruct (compare x z); auto.
+   elim (lt_not_eq H); apply eq_trans with z; auto.
+   elim (lt_not_eq (lt_trans l H)); auto.
+  Qed. 
+
+  Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z.    
+  Proof.
+   intros; destruct (compare x z); auto.
+   elim (lt_not_eq H0); apply eq_trans with x; auto.
+   elim (lt_not_eq (lt_trans H0 l)); auto.
+  Qed. 
+
+  Lemma le_eq : forall x y z, ~lt x y -> eq y z -> ~lt x z.
+  Proof.
+   intros; intro; destruct H; apply lt_eq with z; auto.
+  Qed.
+
+  Lemma eq_le : forall x y z, eq x y -> ~lt y z -> ~lt x z.
+  Proof.
+   intros; intro; destruct H0; apply eq_lt with x; auto.
+  Qed.
+
+  Lemma neq_eq : forall x y z, ~eq x y -> eq y z -> ~eq x z.
+  Proof.
+   intros; intro; destruct H; apply eq_trans with z; auto.
+  Qed.
+
+  Lemma eq_neq : forall x y z, eq x y -> ~eq y z -> ~eq x z.
+  Proof.
+   intros; intro; destruct H0; apply eq_trans with x; auto.
+  Qed.
+
+  Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq.
+
+  Lemma le_lt_trans : forall x y z, ~lt y x -> lt y z -> lt x z.
+  Proof.
+   intros; destruct (compare y x); auto.
+   elim (H l).
+   apply eq_lt with y; auto.
+   apply lt_trans with y; auto.
+  Qed.
+
+  Lemma lt_le_trans : forall x y z, lt x y -> ~lt z y -> lt x z.
+  Proof.
+   intros; destruct (compare z y); auto.
+   elim (H0 l).
+   apply lt_eq with y; auto.
+   apply lt_trans with y; auto.
+  Qed.
+
+  Lemma le_neq : forall x y, ~lt x y -> ~eq x y -> lt y x.
+  Proof. 
+   intros; destruct (compare x y); intuition.
+  Qed.
+
+  Lemma neq_sym : forall x y, ~eq x y -> ~eq y x.
+  Proof. 
+   intuition.
+  Qed.
+
+Ltac abstraction := match goal with 
+ (* First, some obvious simplifications *)
+ | H : False |- _ => elim H
+ | H : lt ?x ?x |- _ => elim (lt_antirefl H)
+ | H : ~eq ?x ?x |- _ => elim (H (eq_refl x))
+ | H : eq ?x ?x |- _ => clear H; abstraction
+ | H : ~lt ?x ?x |- _ => clear H; abstraction
+ | |- eq ?x ?x => exact (eq_refl x)
+ | |- lt ?x ?x => elimtype False; abstraction
+ | |- ~ _ => intro; abstraction
+ | H1: ~lt ?x ?y, H2: ~eq ?x ?y |- _ => 
+     generalize (le_neq H1 H2); clear H1 H2; intro; abstraction
+ | 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 : eq ?x ?y |- _ =>  revert H; abstraction
+ | _ => idtac
+end.
+
+Ltac do_eq a b Eq := match goal with 
+ | |- lt ?x ?y -> _ => let H := fresh "H" in 
+     (intro H; 
+      (generalize (eq_lt (eq_sym Eq) H); clear H; intro H) ||
+      (generalize (lt_eq H Eq); clear H; intro H) || 
+      idtac); 
+      do_eq a b Eq
+ | |- ~lt ?x ?y -> _ => let H := fresh "H" in 
+     (intro H; 
+      (generalize (eq_le (eq_sym Eq) H); clear H; intro H) ||
+      (generalize (le_eq H Eq); clear H; intro H) || 
+      idtac); 
+      do_eq a b Eq 
+ | |- eq ?x ?y -> _ => let H := fresh "H" in 
+     (intro H; 
+      (generalize (eq_trans (eq_sym Eq) H); clear H; intro H) ||
+      (generalize (eq_trans H Eq); clear H; intro H) || 
+      idtac); 
+      do_eq a b Eq 
+ | |- ~eq ?x ?y -> _ => let H := fresh "H" in 
+     (intro H; 
+      (generalize (eq_neq (eq_sym Eq) H); clear H; intro H) ||
+      (generalize (neq_eq H Eq); clear H; intro H) || 
+      idtac); 
+      do_eq a b Eq 
+ | |- lt a ?y => apply eq_lt with b; [exact Eq|]
+ | |- lt ?y a => apply lt_eq with b; [|exact (eq_sym Eq)]
+ | |- eq a ?y => apply eq_trans with b; [exact Eq|]
+ | |- eq ?y a => apply eq_trans with b; [|exact (eq_sym Eq)]
+ | _ => idtac
+ end.
+
+Ltac propagate_eq := abstraction; clear; match goal with 
+ (* the abstraction tactic leaves equality facts in head position...*)
+ | |- eq ?a ?b -> _ => 
+     let Eq := fresh "Eq" in (intro Eq; do_eq a b Eq; clear Eq); 
+     propagate_eq 
+ | _ => idtac
+end.
+
+Ltac do_lt x y Lt := match goal with 
+ (* Lt *)
+ | |- lt x y -> _ => intros _; do_lt x y Lt
+ | |- lt y ?z -> _ => let H := fresh "H" in 
+     (intro H; generalize (lt_trans Lt H); intro); do_lt x y Lt
+ | |- 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 *)
+ | |- ~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
+ | |- ~lt ?z y -> _ => let H := fresh "H" in 
+     (intro H; generalize (lt_le_trans Lt H); intro); do_lt x y Lt
+ | |- ~lt _ _ -> _ => intro; do_lt x y Lt
+ | _ => idtac
+ end.
+
+Definition hide_lt := lt.
+
+Ltac propagate_lt := abstraction; match goal with 
+ (* when no [=] remains, the abstraction tactic leaves [<] facts first. *)
+ | |- lt ?x ?y -> _ => 
+     let Lt := fresh "Lt" in (intro Lt; do_lt x y Lt; 
+     change (hide_lt x y) in Lt); 
+     propagate_lt 
+ | _ => unfold hide_lt in *
+end.
+
+Ltac order := 
+ intros; 
+ propagate_eq; 
+ propagate_lt; 
+ auto; 
+ propagate_lt; 
+ eauto.
+
+Ltac false_order := elimtype False; order.
+
+  Lemma gt_not_eq : forall x y, lt y x -> ~ eq x y.
+  Proof.
+    order.
+  Qed.	
+ 
+  Lemma eq_not_lt : forall x y : t, eq x y -> ~ lt x y.
+  Proof. 
+    order.
+  Qed.
+
+  Hint Resolve gt_not_eq eq_not_lt.
+
+  Lemma eq_not_gt : forall x y : t, eq x y -> ~ lt y x.
+  Proof. 
+   order.
+  Qed.
+
+  Lemma lt_not_gt : forall x y : t, lt x y -> ~ lt y x.
+  Proof.  
+   order.
+  Qed.
+
+  Hint Resolve eq_not_gt lt_antirefl lt_not_gt.
+
+  Lemma elim_compare_eq :
+   forall x y : t,
+   eq x y -> exists H : eq x y, compare x y = Eq _ H.
+  Proof. 
+   intros; case (compare x y); intros H'; try solve [false_order].
+   exists H'; auto.   
+  Qed.
+
+  Lemma elim_compare_lt :
+   forall x y : t,
+   lt x y -> exists H : lt x y, compare x y = Lt _ H.
+  Proof. 
+   intros; case (compare x y); intros H'; try solve [false_order].
+   exists H'; auto. 
+  Qed.
+
+  Lemma elim_compare_gt :
+   forall x y : t,
+   lt y x -> exists H : lt y x, compare x y = Gt _ H.
+  Proof. 
+   intros; case (compare x y); intros H'; try solve [false_order].
+   exists H'; auto.   
+  Qed.
+
+  Ltac elim_comp := 
+    match goal with 
+      | |- ?e => match e with 
+           | context ctx [ compare ?a ?b ] =>
+                let H := fresh in 
+                (destruct (compare a b) as [H|H|H]; 
+                 try solve [ intros; false_order])
+         end
+    end.
+
+  Ltac elim_comp_eq x y :=
+    elim (elim_compare_eq (x:=x) (y:=y));
+     [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. 
+
+  Ltac elim_comp_lt x y :=
+    elim (elim_compare_lt (x:=x) (y:=y));
+     [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. 
+
+  Ltac elim_comp_gt x y :=
+    elim (elim_compare_gt (x:=x) (y:=y));
+     [ intros _1 _2; rewrite _2; clear _1 _2 | auto ].
+
+  Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
+  Proof.
+   intros; elim (compare x y); [ right | left | right ]; auto.
+  Qed.
+ 
+  Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}.
+  Proof.
+   intros; elim (compare x y); [ left | right | right ]; auto.
+  Qed.
+
+  Definition eqb x y : bool := if eq_dec x y then true else false.
+
+  Lemma eqb_alt : 
+    forall x y, eqb x y = match compare x y with Eq _ => true | _ => false end. 
+  Proof.
+  unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto.
+  Qed.
+
+(* Specialization of resuts about lists modulo. *)
+
+Notation In:=(InA eq).
+Notation Inf:=(lelistA lt).
+Notation Sort:=(sort lt).
+Notation NoRedun:=(noredunA eq).
+
+Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
+Proof. exact (InA_eqA eq_sym eq_trans). Qed.
+
+Lemma ListIn_In : forall l x, List.In x l -> In x l.
+Proof. exact (In_InA eq_refl). Qed.
+
+Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l.
+Proof. exact (InfA_ltA lt_trans). Qed.
+ 
+Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l.
+Proof. exact (InfA_eqA eq_lt). Qed.
+
+Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x.
+Proof. exact (SortA_InfA_InA eq_refl eq_sym lt_trans lt_eq eq_lt). Qed.
+  
+Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l.
+Proof. exact (@In_InfA t lt). Qed.
+
+Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l.
+Proof. exact (InA_InfA eq_refl (ltA:=lt)). Qed.
+
+Lemma Inf_alt : 
+ forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)).
+Proof. exact (InfA_alt eq_refl eq_sym lt_trans lt_eq eq_lt). Qed.
+
+Lemma Sort_NoRedun : forall l, Sort l -> NoRedun l.
+Proof. exact (SortA_noredunA eq_refl eq_sym lt_trans lt_not_eq lt_eq eq_lt) . Qed.
+
+Hint Resolve ListIn_In Sort_NoRedun Inf_lt. 
+Hint Immediate In_eq Inf_lt. 
+
+End OrderedTypeFacts.
+
+Module PairOrderedType(O:OrderedType).
+ Import O.
+ Module MO:=OrderedTypeFacts(O).
+ Import MO.
+
+ Section Elt.
+ Variable elt : Set.
+ Notation key:=t.
+
+  Definition eqk (p p':key*elt) := eq (fst p) (fst p').
+  Definition eqke (p p':key*elt) := 
+          eq (fst p) (fst p') /\ (snd p) = (snd p').
+  Definition ltk (p p':key*elt) := lt (fst p) (fst p').
+
+  Hint Unfold eqk eqke ltk.
+  Hint Extern 2 (eqke ?a ?b) => split.
+
+   (* eqke is stricter than eqk *)
+ 
+   Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'.
+   Proof.
+     unfold eqk, eqke; intuition.
+   Qed.
+
+  (* ltk ignore the second components *)
+
+   Lemma ltk_right_r : forall x k e e', ltk x (k,e) -> ltk x (k,e').
+   Proof. auto. Qed.
+
+   Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x.
+   Proof. auto. Qed.
+   Hint Immediate ltk_right_r ltk_right_l.
+
+  (* eqk, eqke are equalities, ltk is a strict order *)
+ 
+  Lemma eqk_refl : forall e, eqk e e.
+  Proof. auto. Qed.
+
+  Lemma eqke_refl : forall e, eqke e e.
+  Proof. auto. Qed.
+
+  Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e.
+  Proof. auto. Qed.
+
+  Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e.
+  Proof. unfold eqke; intuition. Qed.
+
+  Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''.
+  Proof. eauto. Qed.
+
+  Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''.
+  Proof.
+    unfold eqke; intuition; [ eauto | congruence ].
+  Qed.
+
+  Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''.
+  Proof. eauto. Qed.
+
+  Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'.
+  Proof. unfold eqk, ltk; auto. Qed.  
+
+  Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'.
+  Proof.
+    unfold eqke, ltk; intuition; simpl in *; subst.
+    exact (lt_not_eq H H1).
+  Qed.
+
+  Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
+  Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke.
+  Hint Immediate eqk_sym eqke_sym.
+
+  (* Additionnal facts *)
+
+  Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'.
+   Proof.
+     unfold eqk, ltk; simpl; auto.
+   Qed.
+
+  Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''.
+  Proof. eauto. Qed.
+
+  Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''.
+  Proof.
+      intros (k,e) (k',e') (k'',e'').
+      unfold ltk, eqk; simpl; eauto.
+  Qed.
+  Hint Resolve eqk_not_ltk. 
+  Hint Immediate ltk_eqk eqk_ltk.
+
+  Lemma InA_eqke_eqk : 
+     forall x m, InA eqke x m -> InA eqk x m.
+  Proof.
+    unfold eqke; induction 1; intuition.
+  Qed.
+  Hint Resolve InA_eqke_eqk.
+
+  Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
+  Definition In k m := exists e:elt, MapsTo k e m.
+  Notation Sort := (sort ltk).
+  Notation Inf := (lelistA ltk).
+
+  Hint Unfold MapsTo In.
+
+  (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)
+
+  Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
+  Proof.
+  firstorder.
+  exists x; auto.
+  induction H.
+  destruct y.
+  exists e; auto.
+  destruct IHInA as [e H0].
+  exists e; auto.
+  Qed.
+
+  Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
+  Proof.
+  intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto.
+  Qed.
+
+  Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
+  Proof.
+  destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto.
+  Qed. 
+
+  Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l.
+  Proof. exact (InfA_eqA eqk_ltk). Qed.
+
+  Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l.
+  Proof. exact (InfA_ltA ltk_trans). Qed.
+
+  Hint Immediate Inf_eq.
+  Hint Resolve Inf_lt.
+
+  Lemma Sort_Inf_In : 
+      forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p.
+  Proof. 
+  exact (SortA_InfA_InA eqk_refl eqk_sym ltk_trans ltk_eqk eqk_ltk).
+  Qed.
+
+  Lemma Sort_Inf_NotIn : 
+      forall l k e, Sort l -> Inf (k,e) l ->  ~In k l.
+  Proof.
+    intros; red; intros.
+    destruct H1 as [e' H2].
+    elim (@ltk_not_eqk (k,e) (k,e')).
+    eapply Sort_Inf_In; eauto.
+    red; simpl; auto.
+  Qed.
+
+  Lemma Sort_noredunA: forall l, Sort l -> noredunA eqk l.
+  Proof. 
+  exact (SortA_noredunA eqk_refl eqk_sym ltk_trans ltk_not_eqk ltk_eqk eqk_ltk).
+  Qed.
+
+  Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'.
+  Proof.
+   inversion 1; intros; eapply Sort_Inf_In; eauto.
+  Qed.
+
+  Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) ->
+      ltk e e' \/ eqk e e'.
+  Proof.
+    inversion_clear 2; auto.
+    left; apply Sort_In_cons_1 with l; auto.
+  Qed.
+
+  Lemma Sort_In_cons_3 : 
+    forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k.
+  Proof.
+    inversion_clear 1; red; intros.
+    destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)).
+  Qed.
+
+  Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
+  Proof.
+    inversion 1.
+    inversion_clear H0; eauto.
+    destruct H1; simpl in *; intuition.
+  Qed.      
+
+  Lemma In_inv_2 : forall k k' e e' l, 
+      InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
+  Proof.  
+   inversion_clear 1; compute in H0; intuition.
+  Qed.
+
+  Lemma In_inv_3 : forall x x' l, 
+      InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
+  Proof.
+   inversion_clear 1; compute in H0; intuition.
+  Qed.
+
+ End Elt.
+
+ Hint Unfold eqk eqke ltk.
+ Hint Extern 2 (eqke ?a ?b) => split.
+ Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl.
+ Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke.
+ Hint Immediate eqk_sym eqke_sym.
+ Hint Resolve eqk_not_ltk. 
+ Hint Immediate ltk_eqk eqk_ltk.
+ Hint Resolve InA_eqke_eqk.
+ Hint Unfold MapsTo In.
+ Hint Immediate Inf_eq.
+ Hint Resolve Inf_lt.
+ Hint Resolve Sort_Inf_NotIn.
+ Hint Resolve In_inv_2 In_inv_3.
+
+End PairOrderedType.
+
+