MSets: a new generation of FSets

Same global ideas (in particular the use of modules/functors), but:

- frequent use of Type Classes inside interfaces/implementation.
  For instance, no more eq_refl/eq_sym/eq_trans, but Equivalence.
  A class StrictOrder for lt in OrderedType. Extensive use of Proper
  and rewrite.

- now that rewrite is mature, we write specifications of set operators
  via iff instead of many separate requirements based on ->. For instance
   add_spec : In y (add x s) <-> E.eq y x \/ In x s.
  Old-style specs are available in the functor Facts.

- compare is now a pure function (t -> t -> comparison) instead of
  returning a dependent type Compare.

- The "Raw" functors (the ones dealing with e.g. list with no
  sortedness proofs yet, but morally sorted when operating on them)
  are given proper interfaces and a generic functor allows to obtain
  a regular set implementation out of a "raw" one.

The last two points allow to manipulate set objects that are completely free
of proof-parts if one wants to. Later proofs will rely on type-classes
instance search mechanism.

No need to emphasis the fact that this new version is severely incompatible
with the earlier one. I've no precise ideas yet on how allowing an easy
transition (functors ?). For the moment, these new Sets are placed alongside
the old ones, in directory MSets (M for Modular, to constrast with forthcoming
CSets, see below). A few files exist currently in version foo.v and foo2.v,
I'll try to merge them without breaking things. Old FSets will probably move
to a contrib later.

Still to be done:
 - adapt FMap in the same way
 - integrate misc stuff like multisets or the map function
 - CSets, i.e. Sets based on Type Classes : Integration of code contributed by
    S. Lescuyer is on the way.

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

27 files changed, 10443 insertions, 13 deletions

diff --git a/Makefile.common b/Makefile.common
index 918d637e1..67abba61b 100644
--- a/Makefile.common
+++ b/Makefile.common
@@ -308,10 +308,16 @@ LOGICVO:=$(addprefix theories/Logic/, \
  Decidable.vo             JMeq.vo                  ClassicalChoice.vo 	\
  ClassicalDescription.vo  RelationalChoice.vo      Diaconescu.vo 	\
  EqdepFacts.vo            ProofIrrelevanceFacts.vo ClassicalEpsilon.vo 	\
- ClassicalUniqueChoice.vo DecidableType.vo         DecidableTypeEx.vo 	\
+ ClassicalUniqueChoice.vo 	\
  Epsilon.vo               ConstructiveEpsilon.vo   Description.vo 	\
  IndefiniteDescription.vo SetIsType.vo             FunctionalExtensionality.vo )
 
+STRUCTURESVO:=$(addprefix theories/Structures/, \
+ DecidableType.vo         DecidableTypeEx.vo \
+ OrderedType.vo           OrderedTypeEx.vo      OrderedTypeAlt.vo \
+ DecidableType2.vo         DecidableType2Ex.vo \
+ OrderedType2.vo           OrderedType2Ex.vo      OrderedType2Alt.vo )
+
 ARITHVO:=$(addprefix theories/Arith/, \
  Arith.vo	Gt.vo          	Between.vo	Le.vo         	\
  Compare.vo	Lt.vo          	Compare_dec.vo	Min.vo        	\
@@ -349,7 +355,8 @@ QARITHVO:=$(addprefix theories/QArith/, \
 
 LISTSVO:=$(addprefix theories/Lists/, \
  ListSet.vo   	Streams.vo 	StreamMemo.vo  \
- TheoryList.vo	List.vo 	SetoidList.vo   ListTactics.vo )
+ TheoryList.vo	List.vo 	SetoidList.vo  SetoidList2.vo \
+ ListTactics.vo )
 
 STRINGSVO:=$(addprefix theories/Strings/, \
  Ascii.vo      	String.vo )
@@ -368,7 +375,6 @@ SETSVO:=$(addprefix theories/Sets/, \
  Partial_Order.vo     	Uniset.vo )
 
 FSETSBASEVO:=$(addprefix theories/FSets/, \
- OrderedType.vo		OrderedTypeEx.vo	OrderedTypeAlt.vo	\
  FSetInterface.vo	FSetList.vo 		FSetBridge.vo        	\
  FSetFacts.vo 		FSetProperties.vo	FSetEqProperties.vo 	\
  FSetWeakList.vo 	FSetAVL.vo           	FSetDecide.vo 		\
@@ -386,6 +392,12 @@ FSETSVO:=$(FSETSBASEVO) $(FSETS_$(FSETS))
 
 ALLFSETS:=$(FSETSBASEVO) $(FSETS_all)
 
+MSETSVO:=$(addprefix theories/MSets/, \
+ MSetInterface.vo	MSetList.vo 		\
+ MSetFacts.vo 		MSetProperties.vo	MSetEqProperties.vo 	\
+ MSetWeakList.vo 	MSetAVL.vo           	MSetDecide.vo 		\
+ MSets.vo )
+
 RELATIONSVO:=$(addprefix theories/Relations/, \
  Operators_Properties.vo	Relation_Definitions.vo \
  Relation_Operators.vo 		Relations.vo )
@@ -511,9 +523,9 @@ PROGRAMVO:=$(addprefix theories/Program/, \
 
 THEORIESVO:=\
   $(INITVO) $(LOGICVO) $(ARITHVO) $(BOOLVO) $(NARITHVO) $(ZARITHVO) \
-  $(SETOIDSVO) $(LISTSVO) $(STRINGSVO) $(SETSVO) $(FSETSVO) \
+  $(SETOIDSVO) $(LISTSVO) $(STRINGSVO) $(SETSVO) $(FSETSVO) $(MSETSVO) \
   $(RELATIONSVO) $(WELLFOUNDEDVO) $(REALSVO)  $(SORTINGVO) $(QARITHVO) \
-  $(NUMBERSVO) $(UNICODEVO) $(CLASSESVO) $(PROGRAMVO)
+  $(NUMBERSVO) $(UNICODEVO) $(CLASSESVO) $(PROGRAMVO) $(STRUCTURESVO)
 
 THEORIESLIGHTVO:= $(INITVO) $(LOGICVO) $(ARITHVO)
 
diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v
index fe2f55311..a0ce827a9 100644
--- a/theories/Classes/Morphisms.v
+++ b/theories/Classes/Morphisms.v
@@ -279,7 +279,7 @@ Program Instance compose_proper A B C R₀ R₁ R₂ :
     unfold compose. apply H. apply H0. apply H1.
   Qed.
 
-(** Coq functions are morphisms for leibniz equality,
+(** Coq functions are morphisms for Leibniz equality,
    applied only if really needed. *)
 
 Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') :
@@ -488,3 +488,98 @@ Ltac proper_reflexive :=
   end.
 
 Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances.
+
+
+(** When the relation on the domain is symmetric, we can
+    inverse the relation on the codomain. Same for binary functions. *)
+
+Lemma proper_sym_flip
+ `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f) :
+ Proper (R1==>inverse R2) f.
+Proof.
+intros A R1 Sym B R2 f Hf.
+intros x x' Hxx'. apply Hf, Sym, Hxx'.
+Qed.
+
+Lemma proper_sym_flip_2
+ `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f) :
+ Proper (R1==>R2==>inverse R3) f.
+Proof.
+intros A R1 Sym1 B R2 Sym2 C R3 f Hf.
+intros x x' Hxx' y y' Hyy'. apply Hf; auto.
+Qed.
+
+(** When the relation on the domain is symmetric, a predicate is
+  compatible with [iff] as soon as it is compatible with [impl].
+  Same with a binary relation. *)
+
+Lemma proper_sym_impl_iff `(Symmetric A R)`(Proper _ (R==>impl) f) :
+ Proper (R==>iff) f.
+Proof.
+intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto.
+Qed.
+
+Lemma proper_sym_impl_iff_2
+ `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>impl) f) :
+ Proper (R==>R'==>iff) f.
+Proof.
+intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'.
+repeat red in Hf. split; eauto.
+Qed.
+
+(** A [PartialOrder] is compatible with its underlying equivalence. *)
+
+Instance PartialOrder_proper `(PartialOrder A eqA R) :
+  Proper (eqA==>eqA==>iff) R.
+Proof.
+intros.
+apply proper_sym_impl_iff_2; auto with *.
+intros x x' Hx y y' Hy Hr.
+transitivity x.
+generalize (partial_order_equivalence x x'); compute; intuition.
+transitivity y; auto.
+generalize (partial_order_equivalence y y'); compute; intuition.
+Qed.
+
+(** From a [PartialOrder] to the corresponding [StrictOrder]:
+     [lt = le /\ ~eq].
+    If the order is total, we could also say [gt = ~le]. *)
+
+Instance PartialOrder_StrictOrder `(PartialOrder A eqA R) :
+  StrictOrder (relation_conjunction R (complement eqA)).
+Proof.
+split; compute.
+intros x (_,Hx). apply Hx, Equivalence_Reflexive.
+intros x y z (Hxy,Hxy') (Hyz,Hyz'). split.
+apply PreOrder_Transitive with y; assumption.
+intro Hxz.
+apply Hxy'.
+apply partial_order_antisym; auto.
+rewrite Hxz; auto.
+Qed.
+
+(** From a [StrictOrder] to the corresponding [PartialOrder]:
+     [le = lt \/ eq].
+    If the order is total, we could also say [ge = ~lt]. *)
+
+Instance StrictOrder_PreOrder
+ `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iff) R) :
+ PreOrder (relation_disjunction R eqA).
+Proof.
+split.
+intros x. right. reflexivity.
+intros x y z [Hxy|Hxy] [Hyz|Hyz].
+left. transitivity y; auto.
+left. rewrite <- Hyz; auto.
+left. rewrite Hxy; auto.
+right. transitivity y; auto.
+Qed.
+
+Instance StrictOrder_PartialOrder
+  `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iff) R) :
+  PartialOrder eqA (relation_disjunction R eqA).
+Proof.
+intros. intros x y. compute. intuition.
+elim (StrictOrder_Irreflexive x).
+transitivity y; auto.
+Qed.
diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v
index bc25fe488..83095720a 100644
--- a/theories/Classes/RelationClasses.v
+++ b/theories/Classes/RelationClasses.v
@@ -47,7 +47,7 @@ Class Reflexive {A} (R : relation A) :=
 Class Irreflexive {A} (R : relation A) :=
   irreflexivity : Reflexive (complement R).
 
-Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclasses_instances.
+Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances.
 
 Class Symmetric {A} (R : relation A) :=
   symmetry : forall x y, R x y -> R y x.
@@ -417,3 +417,30 @@ Instance: RewriteRelation (@relation_equivalence A).
    a rewrite relation. *)
 
 Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA.
+
+(** Strict Order *)
+
+Class StrictOrder {A : Type} (R : relation A) := {
+  StrictOrder_Irreflexive :> Irreflexive R ;
+  StrictOrder_Transitive :> Transitive R
+}.
+
+Instance StrictOrder_Asymmetric `(StrictOrder A R) : Asymmetric R.
+Proof.
+  firstorder.
+Qed.
+
+(** Inversing a [StrictOrder] gives another [StrictOrder] *)
+
+Instance StrictOrder_inverse `(StrictOrder A R) : StrictOrder (inverse R).
+
+(** Same for [PartialOrder]. *)
+
+Instance PreOrder_inverse `(PreOrder A R) : PreOrder (inverse R).
+
+Instance PartialOrder_inverse `(PartialOrder A eqA R) :
+ PartialOrder eqA (inverse R).
+Proof.
+firstorder.
+Qed.
+
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index f2961635e..228661ec6 100644
--- a/theories/Lists/List.v
+++ b/theories/Lists/List.v
@@ -1874,8 +1874,65 @@ Section NatSeq.
 End NatSeq.
 
 
+(** * Existential and universal predicates over lists *)
 
-  (** * Exporting hints and tactics *)
+Inductive ExistsL {A} (P:A->Prop) : list A -> Prop :=
+ | ExistsL_cons_hd : forall x l, P x -> ExistsL P (x::l)
+ | ExistsL_cons_tl : forall x l, ExistsL P l -> ExistsL P (x::l).
+Hint Constructors ExistsL.
+
+Lemma ExistsL_exists : forall A P (l:list A),
+ ExistsL P l <-> (exists x, In x l /\ P x).
+Proof.
+split.
+induction 1; firstorder.
+induction l; firstorder; subst; auto.
+Qed.
+
+Lemma ExistsL_nil : forall A (P:A->Prop), ExistsL P nil <-> False.
+Proof. split; inversion 1. Qed.
+
+Lemma ExistsL_cons : forall A (P:A->Prop) x l,
+ ExistsL P (x::l) <-> P x \/ ExistsL P l.
+Proof. split; inversion 1; auto. Qed.
+
+
+Inductive ForallL {A} (P:A->Prop) : list A -> Prop :=
+ | ForallL_nil : ForallL P nil
+ | ForallL_cons : forall x l, P x -> ForallL P l -> ForallL P (x::l).
+Hint Constructors ForallL.
+
+Lemma ForallL_forall : forall A P (l:list A),
+ ForallL P l <-> (forall x, In x l -> P x).
+Proof.
+split.
+induction 1; firstorder; subst; auto.
+induction l; firstorder.
+Qed.
+
+
+(** * Inversion of predicates over lists based on head symbol *)
+
+Ltac is_list_constr c :=
+ match c with
+  | nil => idtac
+  | (_::_) => idtac
+  | _ => fail
+ end.
+
+Ltac invlist f :=
+ match goal with
+  | H:f ?l |- _ => is_list_constr l; inversion_clear H; invlist f
+  | H:f _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
+  | H:f _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
+  | H:f _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
+  | H:f _ _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
+  | _ => idtac
+ end.
+
+
+
+(** * Exporting hints and tactics *)
 
 
 Hint Rewrite
diff --git a/theories/Lists/SetoidList2.v b/theories/Lists/SetoidList2.v
new file mode 100644
index 000000000..78226cb5d
--- /dev/null
+++ b/theories/Lists/SetoidList2.v
@@ -0,0 +1,850 @@
+(***********************************************************************)
+(*  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$ *)
+
+Require Export List.
+Require Export Sorting.
+Require Export Setoid Basics Morphisms.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Logical relations over lists with respect to a setoid equality
+      or ordering. *)
+
+(** This can be seen as a complement of predicate [lelistA] and [sort]
+    found in [Sorting]. *)
+
+Section Type_with_equality.
+Variable A : Type.
+Variable eqA : A -> A -> Prop.
+
+(** Being in a list modulo an equality relation over type [A]. *)
+
+Inductive InA (x : A) : list A -> Prop :=
+  | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l)
+  | InA_cons_tl : forall y l, InA x l -> InA x (y :: l).
+
+Hint Constructors InA.
+
+(** TODO: it would be nice to have a generic definition instead
+    of the previous one. Having [InA = ExistsL eqA] raises too
+    many compatibility issues. For now, we only state the equivalence: *)
+
+Lemma InA_altdef : forall x l, InA x l <-> ExistsL (eqA x) l.
+Proof. split; induction 1; auto. Qed.
+
+Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l.
+Proof.
+ intuition. invlist InA; auto.
+Qed.
+
+Lemma InA_nil : forall x, InA x nil <-> False.
+Proof.
+ intuition. invlist InA.
+Qed.
+
+(** An alternative definition of [InA]. *)
+
+Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l.
+Proof.
+ intros; rewrite InA_altdef, ExistsL_exists; firstorder.
+Qed.
+
+(** A list without redundancy modulo the equality over [A]. *)
+
+Inductive NoDupA : list A -> Prop :=
+  | NoDupA_nil : NoDupA nil
+  | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l).
+
+Hint Constructors NoDupA.
+
+
+Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA.
+
+(** lists with same elements modulo [eqA] *)
+
+Definition equivlistA l l' := forall x, InA x l <-> InA x l'.
+
+(** lists with same elements modulo [eqA] at the same place *)
+
+Inductive eqlistA : list A -> list A -> Prop :=
+  | eqlistA_nil : eqlistA nil nil
+  | eqlistA_cons : forall x x' l l',
+      eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l').
+
+Hint Constructors eqlistA.
+
+(** Results concerning lists modulo [eqA] *)
+
+Hypothesis eqA_equiv : Equivalence eqA.
+
+Hint Resolve (@Equivalence_Reflexive _ _ eqA_equiv).
+Hint Resolve (@Equivalence_Transitive _ _ eqA_equiv).
+Hint Immediate (@Equivalence_Symmetric _ _ eqA_equiv).
+
+(** First, the two notions [equivlistA] and [eqlistA] are indeed equivlances *)
+
+Global Instance equivlist_equiv : Equivalence equivlistA.
+Proof.
+ firstorder.
+Qed.
+
+Global Instance eqlistA_equiv : Equivalence eqlistA.
+Proof.
+ constructor; red.
+ induction x; auto.
+ induction 1; auto.
+ intros x y z H; revert z; induction H; auto.
+ inversion 1; subst; auto. invlist eqlistA; eauto with *.
+Qed.
+
+(** Moreover, [eqlistA] implies [equivlistA]. A reverse result
+    will be proved later for sorted list without duplicates. *)
+
+Global Instance eqlistA_equivlistA : subrelation eqlistA equivlistA.
+Proof.
+  intros x x' H. induction H.
+  intuition.
+  red; intros.
+  rewrite 2 InA_cons.
+  rewrite (IHeqlistA x0), H; intuition.
+Qed.
+
+(** InA is compatible with eqA (for its first arg) and with
+    equivlistA (and hence eqlistA) for its second arg *)
+
+Global Instance InA_compat : Proper (eqA==>equivlistA==>iff) InA.
+Proof.
+ intros x x' Hxx' l l' Hll'. rewrite (Hll' x).
+ rewrite 2 InA_alt; firstorder.
+Qed.
+
+(** For compatibility, an immediate consequence of [InA_compat] *)
+
+Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l.
+Proof.
+ intros l x y H H'. rewrite <- H; auto.
+Qed.
+Hint Immediate InA_eqA.
+
+Lemma In_InA : forall l x, In x l -> InA x l.
+Proof.
+ simple induction l; simpl; intuition.
+ subst; auto.
+Qed.
+Hint Resolve In_InA.
+
+Lemma InA_split : forall l x, InA x l ->
+ exists l1, exists y, exists l2,
+ eqA x y /\ l = l1++y::l2.
+Proof.
+induction l; intros; inv.
+exists (@nil A); exists a; exists l; auto.
+destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))).
+exists (a::l1); exists y; exists l2; auto.
+split; simpl; f_equal; auto.
+Qed.
+
+Lemma InA_app : forall l1 l2 x,
+ InA x (l1 ++ l2) -> InA x l1 \/ InA x l2.
+Proof.
+ induction l1; simpl in *; intuition.
+ inv; auto.
+ elim (IHl1 l2 x H0); auto.
+Qed.
+
+Lemma InA_app_iff : forall l1 l2 x,
+ InA x (l1 ++ l2) <-> InA x l1 \/ InA x l2.
+Proof.
+ split.
+ apply InA_app.
+ destruct 1; generalize H; do 2 rewrite InA_alt.
+ destruct 1 as (y,(H1,H2)); exists y; split; auto.
+ apply in_or_app; auto.
+ destruct 1 as (y,(H1,H2)); exists y; split; auto.
+ apply in_or_app; auto.
+Qed.
+
+Lemma InA_rev : forall p m,
+ InA p (rev m) <-> InA p m.
+Proof.
+ intros; do 2 rewrite InA_alt.
+ split; intros (y,H); exists y; intuition.
+ rewrite In_rev; auto.
+ rewrite <- In_rev; auto.
+Qed.
+
+
+
+Section NoDupA.
+
+Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' ->
+  (forall x, InA x l -> InA x l' -> False) ->
+  NoDupA (l++l').
+Proof.
+induction l; simpl; auto; intros.
+inv.
+constructor.
+rewrite InA_alt; intros (y,(H4,H5)).
+destruct (in_app_or _ _ _ H5).
+elim H2.
+rewrite InA_alt.
+exists y; auto.
+apply (H1 a).
+auto.
+rewrite InA_alt.
+exists y; auto.
+apply IHl; auto.
+intros.
+apply (H1 x); auto.
+Qed.
+
+Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l).
+Proof.
+induction l.
+simpl; auto.
+simpl; intros.
+inv.
+apply NoDupA_app; auto.
+constructor; auto.
+intro; inv.
+intros x.
+rewrite InA_alt.
+intros (x1,(H2,H3)).
+intro; inv.
+destruct H0.
+rewrite <- H4, H2.
+apply In_InA.
+rewrite In_rev; auto.
+Qed.
+
+Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l').
+Proof.
+ induction l; simpl in *; intros; inv; auto.
+ constructor; eauto.
+ contradict H0.
+ rewrite InA_app_iff in *.
+ rewrite InA_cons.
+ intuition.
+Qed.
+
+Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l').
+Proof.
+ induction l; simpl in *; intros; inv; auto.
+ constructor; eauto.
+ assert (H2:=IHl _ _ H1).
+ inv.
+ rewrite InA_cons.
+ red; destruct 1.
+ apply H0.
+ rewrite InA_app_iff in *; rewrite InA_cons; auto.
+ apply H; auto.
+ constructor.
+ contradict H0.
+ rewrite InA_app_iff in *; rewrite InA_cons; intuition.
+ eapply NoDupA_split; eauto.
+Qed.
+
+Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y ->
+ NoDupA (x::l) -> NoDupA (l1++y::l2) ->
+ equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2).
+Proof.
+ intros; intro a.
+ generalize (H2 a).
+ rewrite !InA_app_iff, !InA_cons.
+ inv.
+ assert (SW:=NoDupA_swap H1). inv.
+ rewrite InA_app_iff in H0.
+ split; intros.
+ assert (~eqA a x) by (contradict H3; rewrite <- H3; auto).
+ assert (~eqA a y) by (rewrite <- H; auto).
+ tauto.
+ assert (OR : eqA a x \/ InA a l) by intuition. clear H6.
+ destruct OR as [EQN|INA]; auto.
+ elim H0.
+ rewrite <-H,<-EQN; auto.
+Qed.
+
+End NoDupA.
+
+
+
+Section Fold.
+
+Variable B:Type.
+Variable eqB:B->B->Prop.
+Variable st:Equivalence eqB.
+Variable f:A->B->B.
+Variable i:B.
+Variable Comp:Proper (eqA==>eqB==>eqB) f.
+
+Lemma fold_right_eqlistA :
+   forall s s', eqlistA s s' ->
+   eqB (fold_right f i s) (fold_right f i s').
+Proof.
+induction 1; simpl; auto with relations.
+apply Comp; auto.
+Qed.
+
+(** [ForallL2] : specifies that a certain binary predicate should
+    always hold when inspecting two different elements of the list. *)
+
+Inductive ForallL2 (R : A -> A -> Prop) : list A -> Prop :=
+  | ForallNil : ForallL2 R nil
+  | ForallCons : forall a l,
+     (forall b, In b l -> R a b) ->
+     ForallL2 R l -> ForallL2 R (a::l).
+Hint Constructors ForallL2.
+
+(** [NoDupA] can be written in terms of [ForallL2] *)
+
+Lemma ForallL2_NoDupA : forall l,
+ ForallL2 (fun a b => ~eqA a b) l <-> NoDupA l.
+Proof.
+ induction l; split; intros; auto.
+ invlist ForallL2. constructor; [ | rewrite <- IHl; auto ].
+ rewrite InA_alt; intros (a',(Haa',Ha')).
+ exact (H0 a' Ha' Haa').
+ invlist NoDupA. constructor; [ | rewrite IHl; auto ].
+ intros b Hb.
+ contradict H0.
+ rewrite InA_alt; exists b; auto.
+Qed.
+
+Lemma ForallL2_impl : forall (R R':A->A->Prop),
+ (forall a b, R a b -> R' a b) ->
+ forall l, ForallL2 R l -> ForallL2 R' l.
+Proof.
+ induction 2; auto.
+Qed.
+
+(** The following definition is easier to use than [ForallL2]. *)
+
+Definition ForallL2_alt (R:A->A->Prop) l :=
+ forall a b, InA a l -> InA b l -> ~eqA a b -> R a b.
+
+Section Restriction.
+Variable R : A -> A -> Prop.
+
+(** [ForallL2] and [ForallL2_alt] are related, but no completely
+    equivalent. For proving one implication, we need to know that the
+    list has no duplicated elements... *)
+
+Lemma ForallL2_equiv1 : forall l, NoDupA l ->
+ ForallL2_alt R l -> ForallL2 R l.
+Proof.
+ induction l; auto.
+ constructor. intros b Hb.
+ inv.
+ apply H0; auto.
+ contradict H1; rewrite H1; auto.
+ apply IHl.
+ inv; auto.
+ intros b c Hb Hc Hneq.
+ apply H0; auto.
+Qed.
+
+(** ... and for proving the other implication, we need to be able
+   to reverse and adapt relation [R] modulo [eqA]. *)
+
+Hypothesis R_sym : Symmetric R.
+Hypothesis R_compat : Proper (eqA==>eqA==>iff) R.
+
+Lemma ForallL2_equiv2 : forall l,
+ ForallL2 R l -> ForallL2_alt R l.
+Proof.
+ induction l.
+ intros _. red. intros a b Ha. inv.
+ inversion_clear 1 as [|? ? H_R Hl].
+ intros b c Hb Hc Hneq.
+ inv.
+ (* b,c = a : impossible *)
+ elim Hneq; eauto.
+ (* b = a, c in l *)
+ rewrite InA_alt in H0; destruct H0 as (d,(Hcd,Hd)).
+ rewrite H, Hcd; auto.
+ (* b in l, c = a *)
+ rewrite InA_alt in H; destruct H as (d,(Hcd,Hd)).
+ rewrite H0, Hcd; auto.
+ (* b,c in l *)
+ apply (IHl Hl); auto.
+Qed.
+
+Lemma ForallL2_equiv : forall l, NoDupA l ->
+ (ForallL2 R l <-> ForallL2_alt R l).
+Proof.
+split; [apply ForallL2_equiv2|apply ForallL2_equiv1]; auto.
+Qed.
+
+Lemma ForallL2_equivlistA : forall l l', NoDupA l' ->
+ equivlistA l l' -> ForallL2 R l -> ForallL2 R l'.
+Proof.
+intros.
+apply ForallL2_equiv1; auto.
+intros a b Ha Hb Hneq.
+red in H0; rewrite <- H0 in Ha,Hb.
+revert a b Ha Hb Hneq.
+change (ForallL2_alt R l).
+apply ForallL2_equiv2; auto.
+Qed.
+
+(** Two-argument functions that allow to reorder their arguments. *)
+Definition transpose (f : A -> B -> B) :=
+  forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)).
+
+(** A version of transpose with restriction on where it should hold *)
+Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) :=
+  forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)).
+
+Variable TraR :transpose_restr R f.
+
+Lemma fold_right_commutes_restr :
+  forall s1 s2 x, ForallL2 R (s1++x::s2) ->
+  eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))).
+Proof.
+induction s1; simpl; auto; intros.
+reflexivity.
+transitivity (f a (f x (fold_right f i (s1++s2)))).
+apply Comp; auto.
+apply IHs1.
+invlist ForallL2; auto.
+apply TraR.
+invlist ForallL2; auto.
+apply H0.
+apply in_or_app; simpl; auto.
+Qed.
+
+Lemma fold_right_equivlistA_restr :
+  forall s s', NoDupA s -> NoDupA s' -> ForallL2 R s ->
+  equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s').
+Proof.
+ simple induction s.
+ destruct s'; simpl.
+ intros; reflexivity.
+ unfold equivlistA; intros.
+ destruct (H2 a).
+ assert (InA a nil) by auto; inv.
+ intros x l Hrec s' N N' F E; simpl in *.
+ assert (InA x s') by (rewrite <- (E x); auto).
+ destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))).
+ subst s'.
+ transitivity (f x (fold_right f i (s1++s2))).
+ apply Comp; auto.
+ apply Hrec; auto.
+ inv; auto.
+ eapply NoDupA_split; eauto.
+ invlist ForallL2; auto.
+ eapply equivlistA_NoDupA_split; eauto.
+ transitivity (f y (fold_right f i (s1++s2))).
+ apply Comp; auto. reflexivity.
+ symmetry; apply fold_right_commutes_restr.
+ apply ForallL2_equivlistA with (x::l); auto.
+Qed.
+
+Lemma fold_right_add_restr :
+  forall s' s x, NoDupA s -> NoDupA s' -> ForallL2 R s' -> ~ InA x s ->
+  equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)).
+Proof.
+ intros; apply (@fold_right_equivlistA_restr s' (x::s)); auto.
+Qed.
+
+End Restriction.
+
+(** we now state similar results, but without restriction on transpose. *)
+
+Variable Tra :transpose f.
+
+Lemma fold_right_commutes : forall s1 s2 x,
+  eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))).
+Proof.
+induction s1; simpl; auto; intros.
+reflexivity.
+transitivity (f a (f x (fold_right f i (s1++s2)))); auto.
+apply Comp; auto.
+Qed.
+
+Lemma fold_right_equivlistA :
+  forall s s', NoDupA s -> NoDupA s' ->
+  equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s').
+Proof.
+intros; apply fold_right_equivlistA_restr with (R:=fun _ _ => True);
+ repeat red; auto.
+apply ForallL2_equiv1; try red; auto.
+Qed.
+
+Lemma fold_right_add :
+  forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s ->
+  equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)).
+Proof.
+ intros; apply (@fold_right_equivlistA s' (x::s)); auto.
+Qed.
+
+End Fold.
+
+Section Remove.
+
+Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.
+
+Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }.
+Proof.
+induction l.
+right; auto.
+intro; inv.
+destruct (eqA_dec x a).
+left; auto.
+destruct IHl.
+left; auto.
+right; intro; inv; contradiction.
+Qed.
+
+Fixpoint removeA (x : A) (l : list A) : list A :=
+  match l with
+    | nil => nil
+    | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl)
+  end.
+
+Lemma removeA_filter : forall x l,
+  removeA x l = filter (fun y => if eqA_dec x y then false else true) l.
+Proof.
+induction l; simpl; auto.
+destruct (eqA_dec x a); auto.
+rewrite IHl; auto.
+Qed.
+
+Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y.
+Proof.
+induction l; simpl; auto.
+split.
+intro; inv.
+destruct 1; inv.
+intros.
+destruct (eqA_dec x a); simpl; auto.
+rewrite IHl; split; destruct 1; split; auto.
+inv; auto.
+destruct H0; transitivity a; auto.
+split.
+intro; inv.
+split; auto.
+contradict n.
+transitivity y; auto.
+rewrite (IHl x y) in H0; destruct H0; auto.
+destruct 1; inv; auto.
+right; rewrite IHl; auto.
+Qed.
+
+Lemma removeA_NoDupA :
+  forall s x, NoDupA s ->  NoDupA (removeA x s).
+Proof.
+simple induction s; simpl; intros.
+auto.
+inv.
+destruct (eqA_dec x a); simpl; auto.
+constructor; auto.
+rewrite removeA_InA.
+intuition.
+Qed.
+
+Lemma removeA_equivlistA : forall l l' x,
+  ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l').
+Proof.
+unfold equivlistA; intros.
+rewrite removeA_InA.
+split; intros.
+rewrite <- H0; split; auto.
+contradict H.
+apply InA_eqA with x0; auto.
+rewrite <- (H0 x0) in H1.
+destruct H1.
+inv; auto.
+elim H2; auto.
+Qed.
+
+End Remove.
+
+
+
+(** Results concerning lists modulo [eqA] and [ltA] *)
+
+Variable ltA : A -> A -> Prop.
+Hypothesis ltA_strorder : StrictOrder ltA.
+Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA.
+
+Hint Resolve (@StrictOrder_Transitive _ _ ltA_strorder).
+
+Notation InfA:=(lelistA ltA).
+Notation SortA:=(sort ltA).
+
+Hint Constructors lelistA sort.
+
+Lemma InfA_ltA :
+ forall l x y, ltA x y -> InfA y l -> InfA x l.
+Proof.
+ destruct l; constructor. inv; eauto.
+Qed.
+
+Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA.
+Proof.
+ intros x x' Hxx' l l' Hll'.
+ inversion_clear Hll'.
+ intuition.
+ split; intro; inv; constructor.
+ rewrite <- Hxx', <- H; auto.
+ rewrite Hxx', H; auto.
+Qed.
+
+(** For compatibility, can be deduced from [InfA_compat] *)
+Lemma InfA_eqA :
+ forall l x y, eqA x y -> InfA y l -> InfA x l.
+Proof.
+ intros l x y H; rewrite H; auto.
+Qed.
+Hint Immediate InfA_ltA InfA_eqA.
+
+Lemma SortA_InfA_InA :
+ forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x.
+Proof.
+ simple induction l.
+ intros. inv.
+ intros. inv.
+ setoid_replace x with a; auto.
+ eauto.
+Qed.
+
+Lemma In_InfA :
+ forall l x, (forall y, In y l -> ltA x y) -> InfA x l.
+Proof.
+ simple induction l; simpl; intros; constructor; auto.
+Qed.
+
+Lemma InA_InfA :
+ forall l x, (forall y, InA y l -> ltA x y) -> InfA x l.
+Proof.
+ simple induction l; simpl; intros; constructor; auto.
+Qed.
+
+(* In fact, this may be used as an alternative definition for InfA: *)
+
+Lemma InfA_alt :
+ forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)).
+Proof.
+split.
+intros; eapply SortA_InfA_InA; eauto.
+apply InA_InfA.
+Qed.
+
+Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2).
+Proof.
+ induction l1; simpl; auto.
+ intros; inv; auto.
+Qed.
+
+Lemma SortA_app :
+ forall l1 l2, SortA l1 -> SortA l2 ->
+ (forall x y, InA x l1 -> InA y l2 -> ltA x y) ->
+ SortA (l1 ++ l2).
+Proof.
+ induction l1; simpl in *; intuition.
+ inv.
+ constructor; auto.
+ apply InfA_app; auto.
+ destruct l2; auto.
+Qed.
+
+Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l.
+Proof.
+ simple induction l; auto.
+ intros x l' H H0.
+ inv.
+ constructor; auto.
+ intro.
+ apply (StrictOrder_Irreflexive x).
+ eapply SortA_InfA_InA; eauto.
+Qed.
+
+
+(** Some results about [eqlistA] *)
+
+Section EqlistA.
+
+Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'.
+Proof.
+induction 1; auto; simpl; congruence.
+Qed.
+
+Global Instance app_eqlistA_compat :
+ Proper (eqlistA==>eqlistA==>eqlistA) (@app A).
+Proof.
+ repeat red; induction 1; simpl; auto.
+Qed.
+
+(** For compatibility, can be deduced from app_eqlistA_compat **)
+Lemma eqlistA_app : forall l1 l1' l2 l2',
+   eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2').
+Proof.
+intros l1 l1' l2 l2' H H'; rewrite H, H'; reflexivity.
+Qed.
+
+Lemma eqlistA_rev_app : forall l1 l1',
+   eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' ->
+   eqlistA ((rev l1)++l2) ((rev l1')++l2').
+Proof.
+induction 1; auto.
+simpl; intros.
+do 2 rewrite app_ass; simpl; auto.
+Qed.
+
+Global Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A).
+Proof.
+repeat red. intros.
+rewrite (app_nil_end (rev x)), (app_nil_end (rev y)).
+apply eqlistA_rev_app; auto.
+Qed.
+
+Lemma eqlistA_rev : forall l1 l1',
+   eqlistA l1 l1' -> eqlistA (rev l1) (rev l1').
+Proof.
+apply rev_eqlistA_compat.
+Qed.
+
+Lemma SortA_equivlistA_eqlistA : forall l l',
+   SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'.
+Proof.
+induction l; destruct l'; simpl; intros; auto.
+destruct (H1 a); assert (InA a nil) by auto; inv.
+destruct (H1 a); assert (InA a nil) by auto; inv.
+inv.
+assert (forall y, InA y l -> ltA a y).
+intros; eapply SortA_InfA_InA with (l:=l); eauto.
+assert (forall y, InA y l' -> ltA a0 y).
+intros; eapply SortA_InfA_InA with (l:=l'); eauto.
+clear H3 H4.
+assert (eqA a a0).
+ destruct (H1 a).
+ destruct (H1 a0).
+ assert (InA a (a0::l')) by auto. inv; auto.
+ assert (InA a0 (a::l)) by auto. inv; auto.
+ elim (StrictOrder_Irreflexive a); eauto.
+constructor; auto.
+apply IHl; auto.
+split; intros.
+destruct (H1 x).
+assert (InA x (a0::l')) by auto. inv; auto.
+rewrite H9,<-H3 in H4. elim (StrictOrder_Irreflexive a); eauto.
+destruct (H1 x).
+assert (InA x (a::l)) by auto. inv; auto.
+rewrite H9,H3 in H4. elim (StrictOrder_Irreflexive a0); eauto.
+Qed.
+
+End EqlistA.
+
+(** A few things about [filter] *)
+
+Section Filter.
+
+Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l).
+Proof.
+induction l; simpl; auto.
+intros; inv; auto.
+destruct (f a); auto.
+constructor; auto.
+apply In_InfA; auto.
+intros.
+rewrite filter_In in H; destruct H.
+eapply SortA_InfA_InA; eauto.
+Qed.
+
+Implicit Arguments eq [ [A] ].
+
+Lemma filter_InA : forall f, Proper (eqA==>eq) f ->
+ forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true.
+Proof.
+clear ltA ltA_compat ltA_strorder.
+intros; do 2 rewrite InA_alt; intuition.
+destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition.
+destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition.
+  rewrite (H _ _ H0); auto.
+destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition.
+  rewrite <- (H _ _ H0); auto.
+Qed.
+
+Lemma filter_split :
+ forall f, (forall x y, f x = true -> f y = false -> ltA x y) ->
+ forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l.
+Proof.
+induction l; simpl; intros; auto.
+inv.
+rewrite IHl at 1; auto.
+case_eq (f a); simpl; intros; auto.
+assert (forall e, In e l -> f e = false).
+  intros.
+  assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)).
+  case_eq (f e); simpl; intros; auto.
+  elim (StrictOrder_Irreflexive e).
+  transitivity a; auto.
+replace (List.filter f l) with (@nil A); auto.
+generalize H3; clear; induction l; simpl; auto.
+case_eq (f a); auto; intros.
+rewrite H3 in H; auto; try discriminate.
+Qed.
+
+End Filter.
+End Type_with_equality.
+
+
+Hint Constructors InA eqlistA NoDupA sort lelistA.
+
+Section Find.
+
+Variable A B : Type.
+Variable eqA : A -> A -> Prop.
+Hypothesis eqA_equiv : Equivalence eqA.
+Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}.
+
+Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B :=
+ match l with
+  | nil => None
+  | (a,b)::l => if f a then Some b else findA f l
+ end.
+
+Lemma findA_NoDupA :
+ forall l a b,
+ NoDupA (fun p p' => eqA (fst p) (fst p')) l ->
+ (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <->
+  findA (fun a' => if eqA_dec a a' then true else false) l = Some b).
+Proof.
+set (eqk := fun p p' : A*B => eqA (fst p) (fst p')).
+set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p').
+induction l; intros; simpl.
+split; intros; try discriminate.
+invlist InA.
+destruct a as (a',b'); rename a0 into a.
+invlist NoDupA.
+split; intros.
+invlist InA.
+compute in H2; destruct H2. subst b'.
+destruct (eqA_dec a a'); intuition.
+destruct (eqA_dec a a'); simpl.
+contradict H0.
+revert e H2; clear - eqA_equiv.
+induction l.
+intros; invlist InA.
+intros; invlist InA; auto.
+destruct a0.
+compute in H; destruct H.
+subst b.
+left; auto.
+compute.
+transitivity a; auto. symmetry; auto.
+rewrite <- IHl; auto.
+destruct (eqA_dec a a'); simpl in *.
+left; split; simpl; congruence.
+right. rewrite IHl; auto.
+Qed.
+
+End Find.
diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v
new file mode 100644
index 000000000..e38bf171e
--- /dev/null
+++ b/theories/MSets/MSetAVL.v
@@ -0,0 +1,1851 @@
+(* -*- coding: utf-8 -*- *)
+(***********************************************************************)
+(*  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$ *)
+
+(** * MSetAVL : Implementation of MSetInterface via AVL trees *)
+
+(** This module implements finite sets using AVL trees.
+    It follows the implementation from Ocaml's standard library,
+
+    All operations given here expect and produce well-balanced trees
+    (in the ocaml sense: heigths of subtrees shouldn't differ by more
+    than 2), and hence has low complexities (e.g. add is logarithmic
+    in the size of the set). But proving these balancing preservations
+    is in fact not necessary for ensuring correct operational behavior
+    and hence fulfilling the MSet interface. As a consequence,
+    balancing results are not part of this file anymore, they can
+    now be found in [MSetFullAVL].
+
+    Four operations ([union], [subset], [compare] and [equal]) have
+    been slightly adapted in order to have only structural recursive
+    calls. The precise ocaml versions of these operations have also
+    been formalized (thanks to Function+measure), see [ocaml_union],
+    [ocaml_subset], [ocaml_compare] and [ocaml_equal] in
+    [MSetFullAVL]. The structural variants compute faster in Coq,
+    whereas the other variants produce nicer and/or (slightly) faster
+    code after extraction.
+*)
+
+Require Import MSetInterface ZArith Int.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Ops : the pure functions *)
+
+Module Ops (Import I:Int)(X:OrderedType) <: WOps X.
+Local Open Scope Int_scope.
+Local Open Scope lazy_bool_scope.
+
+Definition elt := X.t.
+
+(** ** Trees
+
+   The fourth field of [Node] is the height of the tree *)
+
+Inductive tree :=
+  | Leaf : tree
+  | Node : tree -> X.t -> tree -> int -> tree.
+
+Definition t := tree.
+
+(** ** Basic functions on trees: height and cardinal *)
+
+Definition height (s : t) : int :=
+  match s with
+  | Leaf => 0
+  | Node _ _ _ h => h
+  end.
+
+Fixpoint cardinal (s : t) : nat :=
+  match s with
+   | Leaf => 0%nat
+   | Node l _ r _ => S (cardinal l + cardinal r)
+  end.
+
+(** ** Empty Set *)
+
+Definition empty := Leaf.
+
+(** ** Emptyness test *)
+
+Definition is_empty s :=
+  match s with Leaf => true | _ => false end.
+
+(** ** Appartness *)
+
+(** The [mem] function is deciding appartness. It exploits the
+    binary search tree invariant to achieve logarithmic complexity. *)
+
+Fixpoint mem x s :=
+   match s with
+     |  Leaf => false
+     |  Node l y r _ => match X.compare x y with
+             | Lt => mem x l
+             | Eq => true
+             | Gt => mem x r
+         end
+   end.
+
+(** ** Singleton set *)
+
+Definition singleton x := Node Leaf x Leaf 1.
+
+(** ** Helper functions *)
+
+(** [create l x r] creates a node, assuming [l] and [r]
+    to be balanced and [|height l - height r| <= 2]. *)
+
+Definition create l x r :=
+   Node l x r (max (height l) (height r) + 1).
+
+(** [bal l x r] acts as [create], but performs one step of
+    rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)
+
+Definition assert_false := create.
+
+Definition bal l x r :=
+  let hl := height l in
+  let hr := height r in
+  if gt_le_dec hl (hr+2) then
+    match l with
+     | Leaf => assert_false l x r
+     | Node ll lx lr _ =>
+       if ge_lt_dec (height ll) (height lr) then
+         create ll lx (create lr x r)
+       else
+         match lr with
+          | Leaf => assert_false l x r
+          | Node lrl lrx lrr _ =>
+              create (create ll lx lrl) lrx (create lrr x r)
+         end
+    end
+  else
+    if gt_le_dec hr (hl+2) then
+      match r with
+       | Leaf => assert_false l x r
+       | Node rl rx rr _ =>
+         if ge_lt_dec (height rr) (height rl) then
+            create (create l x rl) rx rr
+         else
+           match rl with
+            | Leaf => assert_false l x r
+            | Node rll rlx rlr _ =>
+                create (create l x rll) rlx (create rlr rx rr)
+           end
+      end
+    else
+      create l x r.
+
+(** ** Insertion *)
+
+Fixpoint add x s := match s with
+   | Leaf => Node Leaf x Leaf 1
+   | Node l y r h =>
+      match X.compare x y with
+         | Lt => bal (add x l) y r
+         | Eq => Node l y r h
+         | Gt => bal l y (add x r)
+      end
+  end.
+
+(** ** Join
+
+    Same as [bal] but does not assume anything regarding heights
+    of [l] and [r].
+*)
+
+Fixpoint join l : elt -> t -> t :=
+  match l with
+    | Leaf => add
+    | Node ll lx lr lh => fun x =>
+       fix join_aux (r:t) : t := match r with
+          | Leaf =>  add x l
+          | Node rl rx rr rh =>
+               if gt_le_dec lh (rh+2) then bal ll lx (join lr x r)
+               else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr
+               else create l x r
+          end
+  end.
+
+(** ** Extraction of minimum element
+
+  Morally, [remove_min] is to be applied to a non-empty tree
+  [t = Node l x r h]. Since we can't deal here with [assert false]
+  for [t=Leaf], we pre-unpack [t] (and forget about [h]).
+*)
+
+Fixpoint remove_min l x r : t*elt :=
+  match l with
+    | Leaf => (r,x)
+    | Node ll lx lr lh =>
+       let (l',m) := remove_min ll lx lr in (bal l' x r, m)
+  end.
+
+(** ** Merging two trees
+
+  [merge t1 t2] builds the union of [t1] and [t2] assuming all elements
+  of [t1] to be smaller than all elements of [t2], and
+  [|height t1 - height t2| <= 2].
+*)
+
+Definition merge s1 s2 :=  match s1,s2 with
+  | Leaf, _ => s2
+  | _, Leaf => s1
+  | _, Node l2 x2 r2 h2 =>
+        let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2'
+end.
+
+(** ** Deletion *)
+
+Fixpoint remove x s := match s with
+  | Leaf => Leaf
+  | Node l y r h =>
+      match X.compare x y with
+         | Lt => bal (remove x l) y r
+         | Eq => merge l r
+         | Gt => bal l  y (remove x r)
+      end
+   end.
+
+(** ** Minimum element *)
+
+Fixpoint min_elt s := match s with
+   | Leaf => None
+   | Node Leaf y _  _ => Some y
+   | Node l _ _ _ => min_elt l
+end.
+
+(** ** Maximum element *)
+
+Fixpoint max_elt s := match s with
+   | Leaf => None
+   | Node _ y Leaf  _ => Some y
+   | Node _ _ r _ => max_elt r
+end.
+
+(** ** Any element *)
+
+Definition choose := min_elt.
+
+(** ** Concatenation
+
+    Same as [merge] but does not assume anything about heights.
+*)
+
+Definition concat s1 s2 :=
+   match s1, s2 with
+      | Leaf, _ => s2
+      | _, Leaf => s1
+      | _, Node l2 x2 r2 _ =>
+            let (s2',m) := remove_min l2 x2 r2 in
+            join s1 m s2'
+   end.
+
+(** ** Splitting
+
+    [split x s] returns a triple [(l, present, r)] where
+    - [l] is the set of elements of [s] that are [< x]
+    - [r] is the set of elements of [s] that are [> x]
+    - [present] is [true] if and only if [s] contains  [x].
+*)
+
+Record triple := mktriple { t_left:t; t_in:bool; t_right:t }.
+Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).
+
+Fixpoint split x s : triple := match s with
+  | Leaf => << Leaf, false, Leaf >>
+  | Node l y r h =>
+     match X.compare x y with
+      | Lt => let (ll,b,rl) := split x l in << ll, b, join rl y r >>
+      | Eq => << l, true, r >>
+      | Gt => let (rl,b,rr) := split x r in << join l y rl, b, rr >>
+     end
+ end.
+
+(** ** Intersection *)
+
+Fixpoint inter s1 s2 := match s1, s2 with
+    | Leaf, _ => Leaf
+    | _, Leaf => Leaf
+    | Node l1 x1 r1 h1, _ =>
+            let (l2',pres,r2') := split x1 s2 in
+            if pres then join (inter l1 l2') x1 (inter r1 r2')
+            else concat (inter l1 l2') (inter r1 r2')
+    end.
+
+(** ** Difference *)
+
+Fixpoint diff s1 s2 := match s1, s2 with
+ | Leaf, _ => Leaf
+ | _, Leaf => s1
+ | Node l1 x1 r1 h1, _ =>
+    let (l2',pres,r2') := split x1 s2 in
+    if pres then concat (diff l1 l2') (diff r1 r2')
+    else join (diff l1 l2') x1 (diff r1 r2')
+end.
+
+(** ** Union *)
+
+(** In ocaml, heights of [s1] and [s2] are compared each time in order
+   to recursively perform the split on the smaller set.
+   Unfortunately, this leads to a non-structural algorithm. The
+   following code is a simplification of the ocaml version: no
+   comparison of heights. It might be slightly slower, but
+   experimentally all the tests I've made in ocaml have shown this
+   potential slowdown to be non-significant. Anyway, the exact code
+   of ocaml has also been formalized thanks to Function+measure, see
+   [ocaml_union] in [MSetFullAVL].
+*)
+
+Fixpoint union s1 s2 :=
+ match s1, s2 with
+  | Leaf, _ => s2
+  | _, Leaf => s1
+  | Node l1 x1 r1 h1, _ =>
+     let (l2',_,r2') := split x1 s2 in
+     join (union l1 l2') x1 (union r1 r2')
+ end.
+
+(** ** Elements *)
+
+(** [elements_tree_aux acc t] catenates the elements of [t] in infix
+    order to the list [acc] *)
+
+Fixpoint elements_aux (acc : list X.t) (s : t) : list X.t :=
+  match s with
+   | Leaf => acc
+   | Node l x r _ => elements_aux (x :: elements_aux acc r) l
+  end.
+
+(** then [elements] is an instanciation with an empty [acc] *)
+
+Definition elements := elements_aux nil.
+
+(** ** Filter *)
+
+Fixpoint filter_acc (f:elt->bool) acc s := match s with
+  | Leaf => acc
+  | Node l x r h =>
+     filter_acc f (filter_acc f (if f x then add x acc else acc) l) r
+ end.
+
+Definition filter f := filter_acc f Leaf.
+
+
+(** ** Partition *)
+
+Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t :=
+  match s with
+   | Leaf => acc
+   | Node l x r _ =>
+      let (acct,accf) := acc in
+      partition_acc f
+        (partition_acc f
+           (if f x then (add x acct, accf) else (acct, add x accf)) l) r
+  end.
+
+Definition partition f := partition_acc f (Leaf,Leaf).
+
+(** ** [for_all] and [exists] *)
+
+Fixpoint for_all (f:elt->bool) s := match s with
+  | Leaf => true
+  | Node l x r _ => f x &&& for_all f l &&& for_all f r
+end.
+
+Fixpoint exists_ (f:elt->bool) s := match s with
+  | Leaf => false
+  | Node l x r _ => f x ||| exists_ f l ||| exists_ f r
+end.
+
+(** ** Fold *)
+
+Fixpoint fold (A : Type) (f : elt -> A -> A)(s : t) : A -> A :=
+ fun a => match s with
+  | Leaf => a
+  | Node l x r _ => fold f r (f x (fold f l a))
+ end.
+Implicit Arguments fold [A].
+
+
+(** ** Subset *)
+
+(** In ocaml, recursive calls are made on "half-trees" such as
+   (Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these
+   non-structural calls, we propose here two specialized functions for
+   these situations. This version should be almost as efficient as
+   the one of ocaml (closures as arguments may slow things a bit),
+   it is simply less compact. The exact ocaml version has also been
+   formalized (thanks to Function+measure), see [ocaml_subset] in
+   [MSetFullAVL].
+ *)
+
+Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool :=
+ match s2 with
+  | Leaf => false
+  | Node l2 x2 r2 h2 =>
+     match X.compare x1 x2 with
+      | Eq => subset_l1 l2
+      | Lt => subsetl subset_l1 x1 l2
+      | Gt => mem x1 r2 &&& subset_l1 s2
+     end
+ end.
+
+Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool :=
+ match s2 with
+  | Leaf => false
+  | Node l2 x2 r2 h2 =>
+     match X.compare x1 x2 with
+      | Eq => subset_r1 r2
+      | Lt => mem x1 l2 &&& subset_r1 s2
+      | Gt => subsetr subset_r1 x1 r2
+     end
+ end.
+
+Fixpoint subset s1 s2 : bool := match s1, s2 with
+  | Leaf, _ => true
+  | Node _ _ _ _, Leaf => false
+  | Node l1 x1 r1 h1, Node l2 x2 r2 h2 =>
+     match X.compare x1 x2 with
+      | Eq => subset l1 l2 &&& subset r1 r2
+      | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2
+      | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2
+     end
+ end.
+
+(** ** A new comparison algorithm suggested by Xavier Leroy
+
+    Transformation in C.P.S. suggested by Benjamin Grégoire.
+    The original ocaml code (with non-structural recursive calls)
+    has also been formalized (thanks to Function+measure), see
+    [ocaml_compare] in [MSetFullAVL]. The following code with
+    continuations computes dramatically faster in Coq, and
+    should be almost as efficient after extraction.
+*)
+
+(** Enumeration of the elements of a tree *)
+
+Inductive enumeration :=
+ | End : enumeration
+ | More : elt -> t -> enumeration -> enumeration.
+
+
+(** [cons t e] adds the elements of tree [t] on the head of
+    enumeration [e]. *)
+
+Fixpoint cons s e : enumeration :=
+ match s with
+  | Leaf => e
+  | Node l x r h => cons l (More x r e)
+ end.
+
+(** One step of comparison of elements *)
+
+Definition compare_more x1 (cont:enumeration->comparison) e2 :=
+ match e2 with
+ | End => Gt
+ | More x2 r2 e2 =>
+     match X.compare x1 x2 with
+      | Eq => cont (cons r2 e2)
+      | Lt => Lt
+      | Gt => Gt
+     end
+ end.
+
+(** Comparison of left tree, middle element, then right tree *)
+
+Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 :=
+ match s1 with
+  | Leaf => cont e2
+  | Node l1 x1 r1 _ =>
+     compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2
+  end.
+
+(** Initial continuation *)
+
+Definition compare_end e2 :=
+ match e2 with End => Eq | _ => Lt end.
+
+(** The complete comparison *)
+
+Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End).
+
+(** ** Equality test *)
+
+Definition equal s1 s2 : bool :=
+ match compare s1 s2 with
+  | Eq => true
+  | _ => false
+ end.
+
+End Ops.
+
+
+
+(** * MakeRaw
+
+   Functor of pure functions + a posteriori proofs of invariant
+   preservation *)
+
+Module MakeRaw (Import I:Int)(X:OrderedType) <: RawSets X.
+Include Ops I X.
+
+(** * Invariants *)
+
+(** ** Occurrence in a tree *)
+
+Inductive InT (x : elt) : tree -> Prop :=
+  | IsRoot : forall l r h y, X.eq x y -> InT x (Node l y r h)
+  | InLeft : forall l r h y, InT x l -> InT x (Node l y r h)
+  | InRight : forall l r h y, InT x r -> InT x (Node l y r h).
+
+Definition In := InT.
+
+(** ** Some shortcuts *)
+
+Definition Equal s s' := forall a : elt, InT a s <-> InT a s'.
+Definition Subset s s' := forall a : elt, InT a s -> InT a s'.
+Definition Empty s := forall a : elt, ~ InT a s.
+Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x.
+Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x.
+
+(** ** Binary search trees *)
+
+(** [lt_tree x s]: all elements in [s] are smaller than [x]
+   (resp. greater for [gt_tree]) *)
+
+Definition lt_tree x s := forall y, InT y s -> X.lt y x.
+Definition gt_tree x s := forall y, InT y s -> X.lt x y.
+
+(** [bst t] : [t] is a binary search tree *)
+
+Inductive bst : tree -> Prop :=
+  | BSLeaf : bst Leaf
+  | BSNode : forall x l r h, bst l -> bst r ->
+     lt_tree x l -> gt_tree x r -> bst (Node l x r h).
+
+(** [bst] is the (decidable) invariant our trees will have to satisfy. *)
+
+Definition IsOk := bst.
+
+Class Ok (s:t) : Prop := { ok : bst s }.
+
+Instance bst_Ok `(Hs : bst s) : Ok s := Hs.
+
+Fixpoint ltb_tree x s :=
+ match s with
+  | Leaf => true
+  | Node l y r _ =>
+     match X.compare x y with
+      | Gt => ltb_tree x l && ltb_tree x r
+      | _ => false
+     end
+ end.
+
+Fixpoint gtb_tree x s :=
+ match s with
+  | Leaf => true
+  | Node l y r _ =>
+     match X.compare x y with
+      | Lt => gtb_tree x l && gtb_tree x r
+      | _ => false
+     end
+ end.
+
+Fixpoint isok s :=
+ match s with
+  | Leaf => true
+  | Node l x r _ => isok l && isok r && ltb_tree x l && gtb_tree x r
+ end.
+
+
+(** * Correctness proofs *)
+
+(* Module Proofs. *)
+ Module MX := OrderedTypeFacts X.
+ Hint Resolve MX.lt_trans.
+
+(** * Automation and dedicated tactics *)
+
+Hint Unfold In.
+Hint Constructors InT bst.
+Hint Unfold lt_tree gt_tree.
+Hint Resolve @ok.
+Hint Constructors Ok.
+
+Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h)
+ "as" ident(s) :=
+ set (s:=Node l x r h) in *; clearbody s; clear l x r h.
+
+(** Automatic treatment of [Ok] hypothesis *)
+
+Ltac inv_ok := match goal with
+ | H:Ok (Node _ _ _ _) |- _ => apply @ok in H; inversion_clear H; inv_ok
+ | H:Ok Leaf |- _ => clear H; inv_ok
+ | H:bst _ |- _ => generalize (Build_Ok H); clear H; intro H; inv_ok
+ | _ => idtac
+end.
+
+(** A tactic to repeat [inversion_clear] on all hyps of the
+    form [(f (Node _ _ _ _))] *)
+
+Ltac is_tree_constr c :=
+  match c with
+   | Leaf => idtac
+   | Node _ _ _ _ => idtac
+   | _ => fail
+  end.
+
+Ltac invtree f :=
+  match goal with
+     | H:f ?s |- _ => is_tree_constr s; inversion_clear H; invtree f
+     | H:f _ ?s |- _ => is_tree_constr s; inversion_clear H; invtree f
+     | H:f _ _ ?s |- _ => is_tree_constr s; inversion_clear H; invtree f
+     | _ => idtac
+  end.
+
+Ltac inv := inv_ok; invtree InT.
+
+Ltac intuition_in := repeat progress (intuition; inv).
+
+(** Helper tactic concerning order of elements. *)
+
+Ltac order := match goal with
+ | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
+ | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order
+ | _ => MX.order
+end.
+
+
+(** [isok] is indeed a decision procedure for [Ok] *)
+
+Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true.
+Proof.
+ induction s as [|l IHl y r IHr h]; simpl.
+ unfold lt_tree; intuition_in.
+ MX.elim_compare x y; intros.
+ split; intros; try discriminate. assert (X.lt y x) by auto. order.
+ split; intros; try discriminate. assert (X.lt y x) by auto. order.
+ rewrite !andb_true_iff, <-IHl, <-IHr.
+  unfold lt_tree; intuition_in; order.
+Qed.
+
+Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true.
+Proof.
+ induction s as [|l IHl y r IHr h]; simpl.
+ unfold gt_tree; intuition_in.
+ MX.elim_compare x y; intros.
+ split; intros; try discriminate. assert (X.lt x y) by auto. order.
+ rewrite !andb_true_iff, <-IHl, <-IHr.
+  unfold gt_tree; intuition_in; order.
+ split; intros; try discriminate. assert (X.lt x y) by auto. order.
+Qed.
+
+Lemma isok_iff : forall s, Ok s <-> isok s = true.
+Proof.
+ induction s as [|l IHl y r IHr h]; simpl.
+ intuition_in.
+ rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff.
+ intuition_in.
+Qed.
+
+Instance isok_Ok `(isok s = true) : Ok s | 10.
+Proof. intros; apply <- isok_iff; auto. Qed.
+
+
+(** * Basic results about [In], [lt_tree], [gt_tree], [height] *)
+
+(** [In] is compatible with [X.eq] *)
+
+Lemma In_1 :
+ forall s x y, X.eq x y -> InT x s -> InT y s.
+Proof.
+ induction s; simpl; intuition_in; eauto 3. (** TODO: why 5 is so slow ? *)
+Qed.
+Hint Immediate In_1.
+
+Instance In_compat : Proper (X.eq==>eq==>iff) InT.
+Proof.
+apply proper_sym_impl_iff_2; auto with *.
+repeat red; intros; subst. apply In_1 with x; auto.
+Qed.
+
+Lemma In_node_iff :
+ forall l x r h y,
+  InT y (Node l x r h) <-> InT y l \/ X.eq y x \/ InT y r.
+Proof.
+ intuition_in.
+Qed.
+
+(** Results about [lt_tree] and [gt_tree] *)
+
+Lemma lt_leaf : forall x : elt, lt_tree x Leaf.
+Proof.
+ red; inversion 1.
+Qed.
+
+Lemma gt_leaf : forall x : elt, gt_tree x Leaf.
+Proof.
+ red; inversion 1.
+Qed.
+
+Lemma lt_tree_node :
+ forall (x y : elt) (l r : tree) (h : int),
+ lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h).
+Proof.
+ unfold lt_tree; intuition_in; order.
+Qed.
+
+Lemma gt_tree_node :
+ forall (x y : elt) (l r : tree) (h : int),
+ gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h).
+Proof.
+ unfold gt_tree; intuition_in; order.
+Qed.
+
+Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node.
+
+Lemma lt_tree_not_in :
+ forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t.
+Proof.
+ intros; intro; order.
+Qed.
+
+Lemma lt_tree_trans :
+ forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t.
+Proof.
+ eauto.
+Qed.
+
+Lemma gt_tree_not_in :
+ forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t.
+Proof.
+ intros; intro; order.
+Qed.
+
+Lemma gt_tree_trans :
+ forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t.
+Proof.
+ eauto.
+Qed.
+
+Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans.
+
+(** * Inductions principles for some of the set operators *)
+
+Functional Scheme bal_ind := Induction for bal Sort Prop.
+Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
+Functional Scheme merge_ind := Induction for merge Sort Prop.
+Functional Scheme min_elt_ind := Induction for min_elt Sort Prop.
+Functional Scheme max_elt_ind := Induction for max_elt Sort Prop.
+Functional Scheme concat_ind := Induction for concat Sort Prop.
+Functional Scheme inter_ind := Induction for inter Sort Prop.
+Functional Scheme diff_ind := Induction for diff Sort Prop.
+Functional Scheme union_ind := Induction for union Sort Prop.
+
+Ltac induct s x :=
+ induction s as [|l IHl x' r IHr h]; simpl; intros;
+ [|MX.elim_compare x x'; intros; inv].
+
+
+(** * Notations and helper lemma about pairs and triples *)
+
+Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
+Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
+Notation "t #l" := (t_left t) (at level 9, format "t '#l'") : pair_scope.
+Notation "t #b" := (t_in t) (at level 9, format "t '#b'") : pair_scope.
+Notation "t #r" := (t_right t) (at level 9, format "t '#r'") : pair_scope.
+
+Open Local Scope pair_scope.
+
+
+(** * Empty set *)
+
+Lemma empty_spec : Empty empty.
+Proof.
+ intro; intro.
+ inversion H.
+Qed.
+
+Instance empty_ok : Ok empty.
+Proof.
+ auto.
+Qed.
+
+(** * Emptyness test *)
+
+Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s.
+Proof.
+ destruct s as [|r x l h]; simpl; auto.
+ split; auto. red; red; intros; inv.
+ split; auto. try discriminate. intro H; elim (H x); auto.
+Qed.
+
+(** * Appartness *)
+
+Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s.
+Proof.
+ split.
+ induct s x; auto; discriminate.
+ induct s x; intuition_in; order.
+Qed.
+
+
+(** * Singleton set *)
+
+Lemma singleton_spec : forall x y, InT y (singleton x) <-> X.eq y x.
+Proof.
+ unfold singleton; intuition_in.
+Qed.
+
+Instance singleton_ok x : Ok (singleton x).
+Proof.
+ unfold singleton; auto.
+Qed.
+
+
+
+(** * Helper functions *)
+
+Lemma create_spec :
+ forall l x r y,  InT y (create l x r) <-> X.eq y x \/ InT y l \/ InT y r.
+Proof.
+ unfold create; split; [ inversion_clear 1 | ]; intuition.
+Qed.
+
+Instance create_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
+ Ok (create l x r).
+Proof.
+ unfold create; auto.
+Qed.
+
+Lemma bal_spec : forall l x r y,
+ InT y (bal l x r) <-> X.eq y x \/ InT y l \/ InT y r.
+Proof.
+ intros l x r; functional induction bal l x r; intros; try clear e0;
+ rewrite !create_spec; intuition_in.
+Qed.
+
+Instance bal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
+ Ok (bal l x r).
+Proof.
+ intros l x r; functional induction bal l x r; intros;
+ inv; repeat apply create_ok; auto; unfold create;
+ (apply lt_tree_node || apply gt_tree_node); auto;
+ (eapply lt_tree_trans || eapply gt_tree_trans); eauto.
+Qed.
+
+
+(** * Insertion *)
+
+Lemma add_spec' : forall s x y,
+ InT y (add x s) <-> X.eq y x \/ InT y s.
+Proof.
+ induct s x; try rewrite ?bal_spec, ?IHl, ?IHr; intuition_in.
+ setoid_replace y with x'; eauto.
+Qed.
+
+Lemma add_spec : forall s x y `{Ok s},
+ InT y (add x s) <-> X.eq y x \/ InT y s.
+Proof. intros; apply add_spec'. Qed.
+
+Instance add_ok s x `(Ok s) : Ok (add x s).
+Proof.
+ induct s x; auto; apply bal_ok; auto.
+ (* lt_tree -> lt_tree (add ...) *)
+ red; red in H3.
+ intros.
+ rewrite add_spec' in H.
+ intuition.
+ eauto.
+ (* gt_tree -> gt_tree (add ...) *)
+ red; red in H3.
+ intros.
+ rewrite add_spec' in H.
+ intuition.
+ setoid_replace y with x; auto.
+Qed.
+
+
+Open Scope Int_scope.
+
+(** * Join *)
+
+(* Function/Functional Scheme can't deal with internal fix.
+   Let's do its job by hand: *)
+
+Ltac join_tac :=
+ intro l; induction l as [| ll _ lx lr Hlr lh];
+   [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join;
+     [ | destruct (gt_le_dec lh (rh+2));
+       [ match goal with |- context b [ bal ?a ?b ?c] =>
+           replace (bal a b c)
+           with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto]
+         end
+       | destruct (gt_le_dec rh (lh+2));
+         [ match goal with |- context b [ bal ?a ?b ?c] =>
+             replace (bal a b c)
+             with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto]
+           end
+         | ] ] ] ]; intros.
+
+Lemma join_spec : forall l x r y,
+ InT y (join l x r) <-> X.eq y x \/ InT y l \/ InT y r.
+Proof.
+ join_tac.
+ simpl.
+ rewrite add_spec'; intuition_in.
+ rewrite add_spec'; intuition_in.
+ rewrite bal_spec, Hlr; clear Hlr Hrl; intuition_in.
+ rewrite bal_spec, Hrl; clear Hlr Hrl; intuition_in.
+ apply create_spec.
+Qed.
+
+Instance join_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) :
+ Ok (join l x r).
+Proof.
+ join_tac; auto with *; inv; apply bal_ok; auto;
+ clear Hrl Hlr z; intro; intros; rewrite join_spec in *.
+ intuition; [ setoid_replace y with x | ]; eauto.
+ intuition; [ setoid_replace y with x | ]; eauto.
+Qed.
+
+
+(** * Extraction of minimum element *)
+
+Lemma remove_min_spec : forall l x r h y,
+ InT y (Node l x r h) <->
+  X.eq y (remove_min l x r)#2 \/ InT y (remove_min l x r)#1.
+Proof.
+ intros l x r; functional induction (remove_min l x r); simpl in *; intros.
+ intuition_in.
+ rewrite bal_spec, In_node_iff, IHp, e0; simpl; intuition.
+Qed.
+
+Instance remove_min_ok l x r h `(Ok (Node l x r h)) :
+ Ok (remove_min l x r)#1.
+Proof.
+ intros l x r; functional induction (remove_min l x r); simpl; intros.
+ inv; auto.
+ assert (O : Ok (Node ll lx lr _x)) by (inv; auto).
+ assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto).
+ specialize IHp with (1:=O); rewrite e0 in IHp; auto; simpl in *.
+ apply bal_ok; auto.
+ inv; auto.
+ intro y; specialize (L y).
+ rewrite remove_min_spec, e0 in L; simpl in L; intuition.
+ inv; auto.
+Qed.
+
+Lemma remove_min_gt_tree : forall l x r h `{Ok (Node l x r h)},
+ gt_tree (remove_min l x r)#2 (remove_min l x r)#1.
+Proof.
+ intros l x r; functional induction (remove_min l x r); simpl; intros.
+ inv; auto.
+ assert (O : Ok (Node ll lx lr _x)) by (inv; auto).
+ assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto).
+ specialize IHp with (1:=O); rewrite e0 in IHp; simpl in IHp.
+ intro y; rewrite bal_spec; intuition;
+  specialize (L m); rewrite remove_min_spec, e0 in L; simpl in L;
+   [setoid_replace y with x|inv]; eauto.
+Qed.
+Hint Resolve remove_min_gt_tree.
+
+
+
+(** * Merging two trees *)
+
+Lemma merge_spec : forall s1 s2 y,
+ InT y (merge s1 s2) <-> InT y s1 \/ InT y s2.
+Proof.
+ intros s1 s2; functional induction (merge s1 s2); intros;
+ try factornode _x _x0 _x1 _x2 as s1.
+ intuition_in.
+ intuition_in.
+ rewrite bal_spec, remove_min_spec, e1; simpl; intuition.
+Qed.
+
+Instance merge_ok s1 s2 `(Ok s1, Ok s2)
+ `(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2) :
+ Ok (merge s1 s2).
+Proof.
+ intros s1 s2; functional induction (merge s1 s2); intros; auto;
+ try factornode _x _x0 _x1 _x2 as s1.
+ apply bal_ok; auto.
+ change s2' with ((s2',m)#1); rewrite <-e1; eauto with *.
+ intros y Hy.
+ apply H1; auto.
+ rewrite remove_min_spec, e1; simpl; auto.
+ change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto.
+Qed.
+
+
+
+(** * Deletion *)
+
+Lemma remove_spec : forall s x y `{Ok s},
+ (InT y (remove x s) <-> InT y s /\ ~ X.eq y x).
+Proof.
+ induct s x.
+ intuition_in.
+ rewrite merge_spec; intuition; [order|order|intuition_in].
+ elim H6; eauto.
+ rewrite bal_spec, IHl; clear IHl IHr; intuition; [order|order|intuition_in].
+ rewrite bal_spec, IHr; clear IHl IHr; intuition; [order|order|intuition_in].
+Qed.
+
+Instance remove_ok s x `(Ok s) : Ok (remove x s).
+Proof.
+ induct s x.
+ auto.
+ (* EQ *)
+ apply merge_ok; eauto.
+ (* LT *)
+ apply bal_ok; auto.
+ intro z; rewrite remove_spec; auto; destruct 1; eauto.
+ (* GT *)
+ apply bal_ok; auto.
+ intro z; rewrite remove_spec; auto; destruct 1; eauto.
+Qed.
+
+
+(** * Minimum element *)
+
+Lemma min_elt_spec1 : forall s x, min_elt s = Some x -> InT x s.
+Proof.
+ intro s; functional induction (min_elt s); auto; inversion 1; auto.
+Qed.
+
+Lemma min_elt_spec2 : forall s x y `{Ok s},
+ min_elt s = Some x -> InT y s -> ~ X.lt y x.
+Proof.
+ intro s; functional induction (min_elt s);
+ try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1.
+ discriminate.
+ intros x y0 U V W.
+ inversion V; clear V; subst.
+ inv; auto.
+ intros; inv; auto.
+ assert (X.lt x y) by (apply H4; apply min_elt_spec1; auto).
+ order.
+ assert (X.lt x1 y) by auto.
+ assert (~X.lt x1 x) by auto.
+ order.
+Qed.
+
+Lemma min_elt_spec3 : forall s, min_elt s = None -> Empty s.
+Proof.
+ intro s; functional induction (min_elt s).
+ red; red; inversion 2.
+ inversion 1.
+ intro H0.
+ destruct (IHo H0 _x2); auto.
+Qed.
+
+
+
+(** * Maximum element *)
+
+Lemma max_elt_spec1 : forall s x, max_elt s = Some x -> InT x s.
+Proof.
+ intro s; functional induction (max_elt s); auto; inversion 1; auto.
+Qed.
+
+Lemma max_elt_spec2 : forall s x y `{Ok s},
+ max_elt s = Some x -> InT y s -> ~ X.lt x y.
+Proof.
+ intro s; functional induction (max_elt s);
+ try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1.
+ discriminate.
+ intros x y0 U V W.
+ inversion V; clear V; subst.
+ inv; auto.
+ intros; inv; auto.
+ assert (X.lt y x1) by auto.
+ assert (~ X.lt x x1) by auto.
+ order.
+ assert (X.lt y x) by (apply H5; apply max_elt_spec1; auto).
+ order.
+Qed.
+
+Lemma max_elt_spec3 : forall s, max_elt s = None -> Empty s.
+Proof.
+ intro s; functional induction (max_elt s).
+ red; auto.
+ inversion 1.
+ intros H0; destruct (IHo H0 _x2); auto.
+Qed.
+
+
+
+(** * Any element *)
+
+Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s.
+Proof.
+ exact min_elt_spec1.
+Qed.
+
+Lemma choose_spec2 : forall s, choose s = None -> Empty s.
+Proof.
+ exact min_elt_spec3.
+Qed.
+
+Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'},
+  choose s = Some x -> choose s' = Some x' ->
+  Equal s s' -> X.eq x x'.
+Proof.
+ unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H.
+ assert (~X.lt x x').
+  apply min_elt_spec2 with s'; auto.
+  rewrite <-H; auto using min_elt_spec1.
+ assert (~X.lt x' x).
+  apply min_elt_spec2 with s; auto.
+  rewrite H; auto using min_elt_spec1.
+ MX.elim_compare x x'; intuition.
+Qed.
+
+
+(** * Concatenation *)
+
+Lemma concat_spec : forall s1 s2 y,
+ InT y (concat s1 s2) <-> InT y s1 \/ InT y s2.
+Proof.
+ intros s1 s2; functional induction (concat s1 s2); intros;
+ try factornode _x _x0 _x1 _x2 as s1.
+ intuition_in.
+ intuition_in.
+ rewrite join_spec, remove_min_spec, e1; simpl; intuition.
+Qed.
+
+Instance concat_ok s1 s2 `(Ok s1, Ok s2)
+ `(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2) :
+ Ok (concat s1 s2).
+Proof.
+ intros s1 s2; functional induction (concat s1 s2); intros; auto;
+ try factornode _x _x0 _x1 _x2 as s1.
+ apply join_ok; auto.
+ change (Ok (s2',m)#1); rewrite <-e1; eauto with *.
+ intros y Hy.
+ apply H1; auto.
+ rewrite remove_min_spec, e1; simpl; auto.
+ change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto.
+Qed.
+
+
+
+(** * Splitting *)
+
+Lemma split_spec1 : forall s x y `{Ok s},
+ (InT y (split x s)#l <-> InT y s /\ X.lt y x).
+Proof.
+ induct s x.
+ intuition_in.
+ intuition_in; order.
+ specialize (IHl x y).
+ destruct (split x l); simpl in *. rewrite IHl; intuition_in; order.
+ specialize (IHr x y).
+ destruct (split x r); simpl in *. rewrite join_spec, IHr; intuition_in; order.
+Qed.
+
+Lemma split_spec2 : forall s x y `{Ok s},
+ (InT y (split x s)#r <-> InT y s /\ X.lt x y).
+Proof.
+ induct s x.
+ intuition_in.
+ intuition_in; order.
+ specialize (IHl x y).
+ destruct (split x l); simpl in *. rewrite join_spec, IHl; intuition_in; order.
+ specialize (IHr x y).
+ destruct (split x r); simpl in *. rewrite IHr; intuition_in; order.
+Qed.
+
+Lemma split_spec3 : forall s x `{Ok s},
+ ((split x s)#b = true <-> InT x s).
+Proof.
+ induct s x.
+ intuition_in; try discriminate.
+ intuition.
+ specialize (IHl x).
+ destruct (split x l); simpl in *. rewrite IHl; intuition_in; order.
+ specialize (IHr x).
+ destruct (split x r); simpl in *. rewrite IHr; intuition_in; order.
+Qed.
+
+Lemma split_ok s x `{Ok s} : Ok (split x s)#l /\ Ok (split x s)#r.
+Proof.
+ induct s x; simpl; auto.
+ specialize (IHl x).
+ generalize (fun y => @split_spec2 _ x y H1).
+ destruct (split x l); simpl in *; intuition. apply join_ok; auto.
+ intros y; rewrite H; intuition.
+ specialize (IHr x).
+ generalize (fun y => @split_spec1 _ x y H2).
+ destruct (split x r); simpl in *; intuition. apply join_ok; auto.
+ intros y; rewrite H; intuition.
+Qed.
+
+Instance split_ok1 s x `(Ok s) : Ok (split x s)#l.
+Proof. intros; destruct (@split_ok s x); auto. Qed.
+
+Instance split_ok2 s x `(Ok s) : Ok (split x s)#r.
+Proof. intros; destruct (@split_ok s x); auto. Qed.
+
+
+(** * Intersection *)
+
+Ltac destruct_split := match goal with
+ | H : split ?x ?s = << ?u, ?v, ?w >> |- _ =>
+   assert ((split x s)#l = u) by (rewrite H; auto);
+   assert ((split x s)#b = v) by (rewrite H; auto);
+   assert ((split x s)#r = w) by (rewrite H; auto);
+   clear H; subst u w
+ end.
+
+Lemma inter_spec_ok : forall s1 s2 `{Ok s1, Ok s2},
+ Ok (inter s1 s2) /\ (forall y, InT y (inter s1 s2) <-> InT y s1 /\ InT y s2).
+Proof.
+ intros s1 s2; functional induction inter s1 s2; intros B1 B2;
+ [intuition_in|intuition_in | | ];
+ factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv;
+ destruct IHt0 as (IHo1,IHi1), IHt1 as (IHo2,IHi2); auto with *;
+ split; intros.
+ (* Ok join *)
+ apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition.
+ (* InT join *)
+ rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
+ setoid_replace y with x1; auto. rewrite <- split_spec3; auto.
+ (* Ok concat *)
+ apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
+ (* InT concat *)
+ rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto.
+ intuition_in.
+ absurd (InT x1 s2).
+  rewrite <- split_spec3; auto; congruence.
+  setoid_replace x1 with y; auto.
+Qed.
+
+Lemma inter_spec : forall s1 s2 y `{Ok s1, Ok s2},
+ (InT y (inter s1 s2) <-> InT y s1 /\ InT y s2).
+Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed.
+
+Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2).
+Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed.
+
+
+(** * Difference *)
+
+Lemma diff_spec_ok : forall s1 s2 `{Ok s1, Ok s2},
+ Ok (diff s1 s2) /\ (forall y, InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2).
+Proof.
+ intros s1 s2; functional induction diff s1 s2; intros B1 B2;
+ [intuition_in|intuition_in | | ];
+ factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv;
+ destruct IHt0 as (IHb1,IHi1), IHt1 as (IHb2,IHi2); auto with *;
+ split; intros.
+ (* Ok concat *)
+ apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order.
+ (* InT concat *)
+ rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in.
+ absurd (InT x1 s2).
+  setoid_replace x1 with y; auto.
+  rewrite <- split_spec3; auto; congruence.
+ (* Ok join *)
+ apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition.
+ (* InT join *)
+ rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *.
+ intuition_in.
+ absurd (InT x1 s2); auto.
+  rewrite <- split_spec3; auto; congruence.
+  setoid_replace x1 with y; auto.
+Qed.
+
+Lemma diff_spec : forall s1 s2 y `{Ok s1, Ok s2},
+ (InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2).
+Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed.
+
+Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2).
+Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed.
+
+
+(** * Union *)
+
+Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2},
+ (InT y (union s1 s2) <-> InT y s1 \/ InT y s2).
+Proof.
+ intros s1 s2; functional induction union s1 s2; intros y B1 B2.
+ intuition_in.
+ intuition_in.
+ factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv.
+ rewrite join_spec, IHt0, IHt1, split_spec1, split_spec2; auto with *.
+ MX.elim_compare y x1; intuition_in.
+Qed.
+
+Instance union_ok s1 s2 `(Ok s1, Ok s2) : Ok (union s1 s2).
+Proof.
+ intros s1 s2; functional induction union s1 s2; intros B1 B2; auto.
+ factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv.
+ apply join_ok; auto with *.
+ intro y; rewrite union_spec, split_spec1; intuition_in.
+ intro y; rewrite union_spec, split_spec2; intuition_in.
+Qed.
+
+
+(** * Elements *)
+
+Lemma elements_spec1' : forall s acc x,
+ InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc.
+Proof.
+ induction s as [ | l Hl x r Hr h ]; simpl; auto.
+ intuition.
+ inversion H0.
+ intros.
+ rewrite Hl.
+ destruct (Hr acc x0); clear Hl Hr.
+ intuition; inversion_clear H3; intuition.
+Qed.
+
+Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s.
+Proof.
+ intros; generalize (elements_spec1' s nil x); intuition.
+ inversion_clear H0.
+Qed.
+
+Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc ->
+ (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) ->
+ sort X.lt (elements_aux acc s).
+Proof.
+ induction s as [ | l Hl y r Hr h]; simpl; intuition.
+ inv.
+ apply Hl; auto.
+ constructor.
+ apply Hr; auto.
+ apply MX.In_Inf; intros.
+ destruct (elements_spec1' r acc y0); intuition.
+ intros.
+ inversion_clear H.
+ order.
+ destruct (elements_spec1' r acc x); intuition eauto.
+Qed.
+
+Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s).
+Proof.
+ intros; unfold elements; apply elements_spec2'; auto.
+ intros; inversion H0.
+Qed.
+Hint Resolve elements_spec2.
+
+Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s).
+Proof.
+ auto.
+Qed.
+
+Lemma elements_aux_cardinal :
+ forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s).
+Proof.
+ simple induction s; simpl in |- *; intuition.
+ rewrite <- H.
+ simpl in |- *.
+ rewrite <- H0; omega.
+Qed.
+
+Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s).
+Proof.
+ exact (fun s => elements_aux_cardinal s nil).
+Qed.
+
+Definition cardinal_spec (s:t)(Hs:Ok s) := elements_cardinal s.
+
+Lemma elements_app :
+ forall s acc, elements_aux acc s = elements s ++ acc.
+Proof.
+ induction s; simpl; intros; auto.
+ rewrite IHs1, IHs2.
+ unfold elements; simpl.
+ rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto.
+Qed.
+
+Lemma elements_node :
+ forall l x r h acc,
+ elements l ++ x :: elements r ++ acc =
+ elements (Node l x r h) ++ acc.
+Proof.
+ unfold elements; simpl; intros; auto.
+ rewrite !elements_app, <- !app_nil_end, !app_ass; auto.
+Qed.
+
+
+(** * Filter *)
+
+Lemma filter_spec' : forall s x acc f,
+ Proper (X.eq==>eq) f ->
+ (InT x (filter_acc f acc s) <-> InT x acc \/ InT x s /\ f x = true).
+Proof.
+ induction s; simpl; intros.
+ intuition_in.
+ rewrite IHs2, IHs1 by (destruct (f t0); auto).
+ case_eq (f t0); intros.
+ rewrite add_spec'; auto.
+ intuition_in.
+ rewrite (H _ _ H2).
+ intuition.
+ intuition_in.
+ rewrite (H _ _ H2) in H3.
+ rewrite H0 in H3; discriminate.
+Qed.
+
+Instance filter_ok' s acc f `(Ok s, Ok acc) :
+ Ok (filter_acc f acc s).
+Proof.
+ induction s; simpl; auto.
+ intros. inv.
+ destruct (f t0); auto with *.
+Qed.
+
+Lemma filter_spec : forall s x f,
+ Proper (X.eq==>eq) f ->
+ (InT x (filter f s) <-> InT x s /\ f x = true).
+Proof.
+ unfold filter; intros; rewrite filter_spec'; intuition_in.
+Qed.
+
+Instance filter_ok s f `(Ok s) : Ok (filter f s).
+Proof.
+ unfold filter; intros; apply filter_ok'; auto.
+Qed.
+
+
+(** * Partition *)
+
+Lemma partition_spec1' : forall s acc f,
+ Proper (X.eq==>eq) f -> forall x : elt,
+ InT x (partition_acc f acc s)#1 <->
+ InT x acc#1 \/ InT x s /\ f x = true.
+Proof.
+ induction s; simpl; intros.
+ intuition_in.
+ destruct acc as [acct accf]; simpl in *.
+ rewrite IHs2 by
+  (destruct (f t0); auto; apply partition_acc_avl_1; simpl; auto).
+ rewrite IHs1 by (destruct (f t0); simpl; auto).
+ case_eq (f t0); simpl; intros.
+ rewrite add_spec'; auto.
+ intuition_in.
+ rewrite (H _ _ H2).
+ intuition.
+ intuition_in.
+ rewrite (H _ _ H2) in H3.
+ rewrite H0 in H3; discriminate.
+Qed.
+
+Lemma partition_spec2' : forall s acc f,
+ Proper (X.eq==>eq) f -> forall x : elt,
+ InT x (partition_acc f acc s)#2 <->
+ InT x acc#2 \/ InT x s /\ f x = false.
+Proof.
+ induction s; simpl; intros.
+ intuition_in.
+ destruct acc as [acct accf]; simpl in *.
+ rewrite IHs2 by
+  (destruct (f t0); auto; apply partition_acc_avl_2; simpl; auto).
+ rewrite IHs1 by (destruct (f t0); simpl; auto).
+ case_eq (f t0); simpl; intros.
+ intuition.
+ intuition_in.
+ rewrite (H _ _ H2) in H3.
+ rewrite H0 in H3; discriminate.
+ rewrite add_spec'; auto.
+ intuition_in.
+ rewrite (H _ _ H2).
+ intuition.
+Qed.
+
+Lemma partition_spec1 : forall s f,
+ Proper (X.eq==>eq) f ->
+ Equal (partition f s)#1 (filter f s).
+Proof.
+ unfold partition; intros s f P x.
+ rewrite partition_spec1', filter_spec; simpl; intuition_in.
+Qed.
+
+Lemma partition_spec2 : forall s f,
+ Proper (X.eq==>eq) f ->
+ Equal (partition f s)#2 (filter (fun x => negb (f x)) s).
+Proof.
+ unfold partition; intros s f P x.
+ rewrite partition_spec2', filter_spec; simpl; intuition_in.
+ rewrite H1; auto.
+ right; split; auto.
+ rewrite negb_true_iff in H1; auto.
+ intros u v H; rewrite H; auto.
+Qed.
+
+Instance partition_ok1' s acc f `(Ok s, Ok acc#1) :
+ Ok (partition_acc f acc s)#1.
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros. inv.
+ destruct (f t0); auto.
+ apply IHs2; simpl; auto.
+ apply IHs1; simpl; auto with *.
+Qed.
+
+Instance partition_ok2' s acc f `(Ok s, Ok acc#2) :
+ Ok (partition_acc f acc s)#2.
+Proof.
+ induction s; simpl; auto.
+ destruct acc as [acct accf]; simpl in *.
+ intros. inv.
+ destruct (f t0); auto.
+ apply IHs2; simpl; auto.
+ apply IHs1; simpl; auto with *.
+Qed.
+
+Instance partition_ok1 s f `(Ok s) : Ok (partition f s)#1.
+Proof. intros; apply partition_ok1'; auto. Qed.
+
+Instance partition_ok2 s f `(Ok s) : Ok (partition f s)#2.
+Proof. intros; apply partition_ok2'; auto. Qed.
+
+
+
+(** * [for_all] and [exists] *)
+
+Lemma for_all_spec : forall s f, Proper (X.eq==>eq) f ->
+ (for_all f s = true <-> For_all (fun x => f x = true) s).
+Proof.
+ split.
+ induction s; simpl; auto; intros; red; intros; inv.
+ destruct (andb_prop _ _ H0); auto.
+ destruct (andb_prop _ _ H1); eauto.
+ apply IHs1; auto.
+ destruct (andb_prop _ _ H0); auto.
+ destruct (andb_prop _ _ H1); auto.
+ apply IHs2; auto.
+ destruct (andb_prop _ _ H0); auto.
+ (* <- *)
+ induction s; simpl; auto.
+ intros.
+ rewrite IHs1; try red; auto.
+ rewrite IHs2; try red; auto.
+ generalize (H0 t0).
+ destruct (f t0); simpl; auto.
+Qed.
+
+Lemma exists_spec : forall s f, Proper (X.eq==>eq) f ->
+ (exists_ f s = true <-> Exists (fun x => f x = true) s).
+Proof.
+ split.
+ induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *.
+ discriminate.
+ destruct (orb_true_elim _ _ H0) as [H1|H1].
+ destruct (orb_true_elim _ _ H1) as [H2|H2].
+ exists t0; auto.
+ destruct (IHs1 H2); auto; exists x; intuition.
+ destruct (IHs2 H1); auto; exists x; intuition.
+ (* <- *)
+ induction s; simpl; destruct 1 as (x,(U,V)); inv; rewrite <- ?orb_lazy_alt.
+ rewrite (H _ _ (MX.eq_sym H0)); rewrite V; auto.
+ apply orb_true_intro; left.
+ apply orb_true_intro; right; apply IHs1; auto; exists x; auto.
+ apply orb_true_intro; right; apply IHs2; auto; exists x; auto.
+Qed.
+
+
+(** * Fold *)
+
+Lemma fold_spec' :
+ forall (A : Type) (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt),
+ fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i).
+Proof.
+ induction s as [|l IHl x r IHr h]; simpl; intros; auto.
+ rewrite IHl.
+ simpl. unfold flip at 2.
+ apply IHr.
+Qed.
+
+Lemma fold_spec :
+ forall (s:t) (A : Type) (i : A) (f : elt -> A -> A),
+ fold f s i = fold_left (flip f) (elements s) i.
+Proof.
+ unfold elements.
+ induction s as [|l IHl x r IHr h]; simpl; intros; auto.
+ rewrite fold_spec'.
+ rewrite IHr.
+ simpl; auto.
+Qed.
+
+
+(** * Subset *)
+
+Lemma subsetl_spec : forall subset_l1 l1 x1 h1 s2
+ `{Ok (Node l1 x1 Leaf h1), Ok s2},
+ (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) ->
+ (subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ).
+Proof.
+ induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros.
+ unfold Subset; intuition; try discriminate.
+ assert (H': InT x1 Leaf) by auto; inversion H'.
+ specialize (IHl2 H).
+ specialize (IHr2 H).
+ inv.
+ MX.elim_compare x1 x2; intros.
+
+ rewrite H1 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite IHl2 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
+ rewrite mem_spec; auto.
+ assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+Qed.
+
+
+Lemma subsetr_spec : forall subset_r1 r1 x1 h1 s2,
+ bst (Node Leaf x1 r1 h1) -> bst s2 ->
+ (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) ->
+ (subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2).
+Proof.
+ induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros.
+ unfold Subset; intuition; try discriminate.
+ assert (H': InT x1 Leaf) by auto; inversion H'.
+ specialize (IHl2 H).
+ specialize (IHr2 H).
+ inv.
+ MX.elim_compare x1 x2; intros.
+
+ rewrite H1 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto;  clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto.
+ rewrite mem_spec; auto.
+ assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite IHr2 by auto; clear H1 IHl2 IHr2.
+ unfold Subset. intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+Qed.
+
+Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2},
+ (subset s1 s2 = true <-> Subset s1 s2).
+Proof.
+ induction s1 as [|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros.
+ unfold Subset; intuition_in.
+ destruct s2 as [|l2 x2 r2 h2]; simpl; intros.
+ unfold Subset; intuition_in; try discriminate.
+ assert (H': InT x1 Leaf) by auto; inversion H'.
+ inv.
+ MX.elim_compare x1 x2; intros.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto.
+ clear IHl1 IHr1.
+ unfold Subset; intuition_in.
+ assert (X.eq a x2) by order; intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto.
+ rewrite (@subsetl_spec (subset l1) l1 x1 h1) by auto.
+ clear IHl1 IHr1.
+ unfold Subset; intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+
+ rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto.
+ rewrite (@subsetr_spec (subset r1) r1 x1 h1) by auto.
+ clear IHl1 IHr1.
+ unfold Subset; intuition_in.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+ assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order.
+Qed.
+
+
+(** * Comparison *)
+
+(** ** Relations [eq] and [lt] over trees *)
+
+Module L := MakeListOrdering X.
+
+Definition eq := Equal.
+Instance eq_equiv : Equivalence eq.
+Proof. firstorder. Qed.
+
+Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s').
+Proof.
+ unfold eq, Equal, L.eq; intros.
+ setoid_rewrite elements_spec1; firstorder.
+Qed.
+
+Definition lt (s1 s2 : t) : Prop :=
+ exists s1', exists s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2'
+   /\ L.lt (elements s1') (elements s2').
+
+Instance lt_strorder : StrictOrder lt.
+Proof.
+ split.
+ intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
+ assert (eqlistA X.eq (elements s1) (elements s2)).
+  apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
+  rewrite <- eq_Leq. transitivity s; auto. symmetry; auto.
+ rewrite H in L.
+ apply (StrictOrder_Irreflexive (elements s2)); auto.
+ intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
+                 (s2'' & s3' & B2' & B3 & E2' & E3 & L23).
+ exists s1', s3'; do 4 (split; trivial).
+ assert (eqlistA X.eq (elements s2') (elements s2'')).
+  apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *.
+  rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto.
+ transitivity (elements s2'); auto.
+ rewrite H; auto.
+Qed.
+
+Instance lt_compat : Proper (eq==>eq==>iff) lt.
+Proof.
+ intros s1 s2 E12 s3 s4 E34. split.
+ intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
+ exists s1', s3'; do 2 (split; trivial).
+  split. transitivity s1; auto. symmetry; auto.
+  split; auto. transitivity s3; auto. symmetry; auto.
+ intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
+ exists s1', s3'; do 2 (split; trivial).
+  split. transitivity s2; auto.
+  split; auto. transitivity s4; auto.
+Qed.
+
+
+(** * Proof of the comparison algorithm *)
+
+(** [flatten_e e] returns the list of elements of [e] i.e. the list
+    of elements actually compared *)
+
+Fixpoint flatten_e (e : enumeration) : list elt := match e with
+  | End => nil
+  | More x t r => x :: elements t ++ flatten_e r
+ end.
+
+Lemma flatten_e_elements :
+ forall l x r h e,
+ elements l ++ flatten_e (More x r e) = elements (Node l x r h) ++ flatten_e e.
+Proof.
+ intros; simpl; apply elements_node.
+Qed.
+
+Lemma cons_1 : forall s e,
+  flatten_e (cons s e) = elements s ++ flatten_e e.
+Proof.
+ induction s; simpl; auto; intros.
+ rewrite IHs1; apply flatten_e_elements.
+Qed.
+
+Hint Unfold flip.
+
+(** Correctness of this comparison *)
+
+Definition LCmp := Cmp L.eq L.lt.
+
+Lemma compare_end_Cmp :
+ forall e2, LCmp (compare_end e2) nil (flatten_e e2).
+Proof.
+ destruct e2; simpl; auto. reflexivity.
+Qed.
+
+Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l,
+  LCmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) ->
+   LCmp (compare_more x1 cont (More x2 r2 e2)) (x1::l)
+      (flatten_e (More x2 r2 e2)).
+Proof.
+ simpl; intros; MX.elim_compare x1 x2; simpl; auto.
+ intros; apply L.cons_Cmp; auto.
+Qed.
+
+Lemma compare_cont_Cmp : forall s1 cont e2 l,
+ (forall e, LCmp (cont e) l (flatten_e e)) ->
+ LCmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2).
+Proof.
+ induction s1 as [|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto.
+ rewrite <- elements_node; simpl.
+ apply Hl1; auto. clear e2. intros [|x2 r2 e2].
+ simpl; auto.
+ apply compare_more_Cmp.
+ rewrite <- cons_1; auto.
+Qed.
+
+Lemma compare_Cmp : forall s1 s2,
+ LCmp (compare s1 s2) (elements s1) (elements s2).
+Proof.
+ intros; unfold compare.
+ rewrite (app_nil_end (elements s1)).
+ replace (elements s2) with (flatten_e (cons s2 End)) by
+  (rewrite cons_1; simpl; rewrite <- app_nil_end; auto).
+ apply compare_cont_Cmp; auto.
+ intros.
+ apply compare_end_Cmp; auto.
+Qed.
+
+Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2},
+ Cmp eq lt (compare s1 s2) s1 s2.
+Proof.
+ intros.
+ generalize (compare_Cmp s1 s2).
+ destruct (compare s1 s2); unfold LCmp, Cmp, flip; auto.
+ rewrite eq_Leq; auto.
+ intros; exists s1, s2; repeat split; auto.
+ intros; exists s2, s1; repeat split; auto.
+Qed.
+
+
+(** * Equality test *)
+
+Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2},
+ equal s1 s2 = true <-> eq s1 s2.
+Proof.
+unfold equal; intros s1 s2 B1 B2.
+generalize (@compare_spec s1 s2 B1 B2).
+destruct (compare s1 s2); simpl; split; intros E; auto; try discriminate.
+rewrite E in H. elim (StrictOrder_Irreflexive s2); auto.
+rewrite E in H. elim (StrictOrder_Irreflexive s2); auto.
+Qed.
+
+End MakeRaw.
+
+
+
+(** * Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we
+   need to encapsulate everything into a type of binary search trees.
+   They also happen to be well-balanced, but this has no influence
+   on the correctness of operations, so we won't state this here,
+   see [MSetFullAVL] if you need more than just the MSet interface.
+*)
+
+Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
+ Module Raw := MakeRaw I X.
+ Include Raw2Sets X Raw.
+End IntMake.
+
+(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)
+
+Module Make (X: OrderedType) <: S with Module E := X
+ :=IntMake(Z_as_Int)(X).
diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v
new file mode 100644
index 000000000..884ed4235
--- /dev/null
+++ b/theories/MSets/MSetDecide.v
@@ -0,0 +1,864 @@
+(***********************************************************************)
+(*  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$ *)
+
+(**************************************************************)
+(* MSetDecide.v                                               *)
+(*                                                            *)
+(* Author: Aaron Bohannon                                     *)
+(**************************************************************)
+
+(** This file implements a decision procedure for a certain
+    class of propositions involving finite sets.  *)
+
+Require Import Decidable DecidableTypeEx MSetFacts.
+
+(** First, a version for Weak Sets in functorial presentation *)
+
+Module WDecideOn (E : DecidableType)(Import M : WSetsOn E).
+ Module F := MSetFacts.WFactsOn E M.
+
+(** * Overview
+    This functor defines the tactic [fsetdec], which will
+    solve any valid goal of the form
+<<
+    forall s1 ... sn,
+    forall x1 ... xm,
+    P1 -> ... -> Pk -> P
+>>
+    where [P]'s are defined by the grammar:
+<<
+
+P ::=
+| Q
+| Empty F
+| Subset F F'
+| Equal F F'
+
+Q ::=
+| E.eq X X'
+| In X F
+| Q /\ Q'
+| Q \/ Q'
+| Q -> Q'
+| Q <-> Q'
+| ~ Q
+| True
+| False
+
+F ::=
+| S
+| empty
+| singleton X
+| add X F
+| remove X F
+| union F F'
+| inter F F'
+| diff F F'
+
+X ::= x1 | ... | xm
+S ::= s1 | ... | sn
+
+>>
+
+The tactic will also work on some goals that vary slightly from
+the above form:
+- The variables and hypotheses may be mixed in any order and may
+  have already been introduced into the context.  Moreover,
+  there may be additional, unrelated hypotheses mixed in (these
+  will be ignored).
+- A conjunction of hypotheses will be handled as easily as
+  separate hypotheses, i.e., [P1 /\ P2 -> P] can be solved iff
+  [P1 -> P2 -> P] can be solved.
+- [fsetdec] should solve any goal if the MSet-related hypotheses
+  are contradictory.
+- [fsetdec] will first perform any necessary zeta and beta
+  reductions and will invoke [subst] to eliminate any Coq
+  equalities between finite sets or their elements.
+- If [E.eq] is convertible with Coq's equality, it will not
+  matter which one is used in the hypotheses or conclusion.
+- The tactic can solve goals where the finite sets or set
+  elements are expressed by Coq terms that are more complicated
+  than variables.  However, non-local definitions are not
+  expanded, and Coq equalities between non-variable terms are
+  not used.  For example, this goal will be solved:
+<<
+    forall (f : t -> t),
+    forall (g : elt -> elt),
+    forall (s1 s2 : t),
+    forall (x1 x2 : elt),
+    Equal s1 (f s2) ->
+    E.eq x1 (g (g x2)) ->
+    In x1 s1 ->
+    In (g (g x2)) (f s2)
+>>
+  This one will not be solved:
+<<
+    forall (f : t -> t),
+    forall (g : elt -> elt),
+    forall (s1 s2 : t),
+    forall (x1 x2 : elt),
+    Equal s1 (f s2) ->
+    E.eq x1 (g x2) ->
+    In x1 s1 ->
+    g x2 = g (g x2) ->
+    In (g (g x2)) (f s2)
+>>
+*)
+
+  (** * Facts and Tactics for Propositional Logic
+      These lemmas and tactics are in a module so that they do
+      not affect the namespace if you import the enclosing
+      module [Decide]. *)
+  Module MSetLogicalFacts.
+    Require Export Decidable.
+    Require Export Setoid.
+
+    (** ** Lemmas and Tactics About Decidable Propositions *)
+
+    (** ** Propositional Equivalences Involving Negation
+        These are all written with the unfolded form of
+        negation, since I am not sure if setoid rewriting will
+        always perform conversion. *)
+
+    (** ** Tactics for Negations *)
+
+    Tactic Notation "fold" "any" "not" :=
+      repeat (
+        match goal with
+        | H: context [?P -> False] |- _ =>
+          fold (~ P) in H
+        | |- context [?P -> False] =>
+          fold (~ P)
+        end).
+
+    (** [push not using db] will pushes all negations to the
+        leaves of propositions in the goal, using the lemmas in
+        [db] to assist in checking the decidability of the
+        propositions involved.  If [using db] is omitted, then
+        [core] will be used.  Additional versions are provided
+        to manipulate the hypotheses or the hypotheses and goal
+        together.
+
+        XXX: This tactic and the similar subsequent ones should
+        have been defined using [autorewrite]. However, dealing
+        with multiples rewrite sites and side-conditions is
+        done more cleverly with the following explicit
+        analysis of goals. *)
+
+    Ltac or_not_l_iff P Q tac :=
+      (rewrite (or_not_l_iff_1 P Q) by tac) ||
+      (rewrite (or_not_l_iff_2 P Q) by tac).
+
+    Ltac or_not_r_iff P Q tac :=
+      (rewrite (or_not_r_iff_1 P Q) by tac) ||
+      (rewrite (or_not_r_iff_2 P Q) by tac).
+
+    Ltac or_not_l_iff_in P Q H tac :=
+      (rewrite (or_not_l_iff_1 P Q) in H by tac) ||
+      (rewrite (or_not_l_iff_2 P Q) in H by tac).
+
+    Ltac or_not_r_iff_in P Q H tac :=
+      (rewrite (or_not_r_iff_1 P Q) in H by tac) ||
+      (rewrite (or_not_r_iff_2 P Q) in H by tac).
+
+    Tactic Notation "push" "not" "using" ident(db) :=
+      let dec := solve_decidable using db in
+      unfold not, iff;
+      repeat (
+        match goal with
+        | |- context [True -> False] => rewrite not_true_iff
+        | |- context [False -> False] => rewrite not_false_iff
+        | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec
+        | |- context [(?P -> False) -> (?Q -> False)] =>
+            rewrite (contrapositive P Q) by dec
+        | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec
+        | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec
+        | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec
+        | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q)
+        | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q)
+        | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec
+        end);
+      fold any not.
+
+    Tactic Notation "push" "not" :=
+      push not using core.
+
+    Tactic Notation
+      "push" "not" "in" "*" "|-" "using" ident(db) :=
+      let dec := solve_decidable using db in
+      unfold not, iff in * |-;
+      repeat (
+        match goal with
+        | H: context [True -> False] |- _ => rewrite not_true_iff in H
+        | H: context [False -> False] |- _ => rewrite not_false_iff in H
+        | H: context [(?P -> False) -> False] |- _ =>
+          rewrite (not_not_iff P) in H by dec
+        | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
+          rewrite (contrapositive P Q) in H by dec
+        | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec
+        | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec
+        | H: context [(?P -> False) -> ?Q] |- _ =>
+          rewrite (imp_not_l P Q) in H by dec
+        | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H
+        | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H
+        | H: context [(?P -> ?Q) -> False] |- _ =>
+          rewrite (not_imp_iff P Q) in H by dec
+        end);
+      fold any not.
+
+    Tactic Notation "push" "not" "in" "*" "|-"  :=
+      push not in * |- using core.
+
+    Tactic Notation "push" "not" "in" "*" "using" ident(db) :=
+      push not using db; push not in * |- using db.
+    Tactic Notation "push" "not" "in" "*" :=
+      push not in * using core.
+
+    (** A simple test case to see how this works.  *)
+    Lemma test_push : forall P Q R : Prop,
+      decidable P ->
+      decidable Q ->
+      (~ True) ->
+      (~ False) ->
+      (~ ~ P) ->
+      (~ (P /\ Q) -> ~ R) ->
+      ((P /\ Q) \/ ~ R) ->
+      (~ (P /\ Q) \/ R) ->
+      (R \/ ~ (P /\ Q)) ->
+      (~ R \/ (P /\ Q)) ->
+      (~ P -> R) ->
+      (~ ((R -> P) \/ (Q -> R))) ->
+      (~ (P /\ R)) ->
+      (~ (P -> R)) ->
+      True.
+    Proof.
+      intros. push not in *.
+       (* note that ~(R->P) remains (since R isnt decidable) *)
+      tauto.
+    Qed.
+
+    (** [pull not using db] will pull as many negations as
+        possible toward the top of the propositions in the goal,
+        using the lemmas in [db] to assist in checking the
+        decidability of the propositions involved.  If [using
+        db] is omitted, then [core] will be used.  Additional
+        versions are provided to manipulate the hypotheses or
+        the hypotheses and goal together. *)
+
+    Tactic Notation "pull" "not" "using" ident(db) :=
+      let dec := solve_decidable using db in
+      unfold not, iff;
+      repeat (
+        match goal with
+        | |- context [True -> False] => rewrite not_true_iff
+        | |- context [False -> False] => rewrite not_false_iff
+        | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec
+        | |- context [(?P -> False) -> (?Q -> False)] =>
+          rewrite (contrapositive P Q) by dec
+        | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec
+        | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec
+        | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec
+        | |- context [(?P -> False) /\ (?Q -> False)] =>
+          rewrite <- (not_or_iff P Q)
+        | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q)
+        | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec
+        | |- context [(?Q -> False) /\ ?P] =>
+          rewrite <- (not_imp_rev_iff P Q) by dec
+        end);
+      fold any not.
+
+    Tactic Notation "pull" "not" :=
+      pull not using core.
+
+    Tactic Notation
+      "pull" "not" "in" "*" "|-" "using" ident(db) :=
+      let dec := solve_decidable using db in
+      unfold not, iff in * |-;
+      repeat (
+        match goal with
+        | H: context [True -> False] |- _ => rewrite not_true_iff in H
+        | H: context [False -> False] |- _ => rewrite not_false_iff in H
+        | H: context [(?P -> False) -> False] |- _ =>
+          rewrite (not_not_iff P) in H by dec
+        | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
+          rewrite (contrapositive P Q) in H by dec
+        | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec
+        | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec
+        | H: context [(?P -> False) -> ?Q] |- _ =>
+          rewrite (imp_not_l P Q) in H by dec
+        | H: context [(?P -> False) /\ (?Q -> False)] |- _ =>
+          rewrite <- (not_or_iff P Q) in H
+        | H: context [?P -> ?Q -> False] |- _ =>
+          rewrite <- (not_and_iff P Q) in H
+        | H: context [?P /\ (?Q -> False)] |- _ =>
+          rewrite <- (not_imp_iff P Q) in H by dec
+        | H: context [(?Q -> False) /\ ?P] |- _ =>
+          rewrite <- (not_imp_rev_iff P Q) in H by dec
+        end);
+      fold any not.
+
+    Tactic Notation "pull" "not" "in" "*" "|-"  :=
+      pull not in * |- using core.
+
+    Tactic Notation "pull" "not" "in" "*" "using" ident(db) :=
+      pull not using db; pull not in * |- using db.
+    Tactic Notation "pull" "not" "in" "*" :=
+      pull not in * using core.
+
+    (** A simple test case to see how this works.  *)
+    Lemma test_pull : forall P Q R : Prop,
+      decidable P ->
+      decidable Q ->
+      (~ True) ->
+      (~ False) ->
+      (~ ~ P) ->
+      (~ (P /\ Q) -> ~ R) ->
+      ((P /\ Q) \/ ~ R) ->
+      (~ (P /\ Q) \/ R) ->
+      (R \/ ~ (P /\ Q)) ->
+      (~ R \/ (P /\ Q)) ->
+      (~ P -> R) ->
+      (~ (R -> P) /\ ~ (Q -> R)) ->
+      (~ P \/ ~ R) ->
+      (P /\ ~ R) ->
+      (~ R /\ P) ->
+      True.
+    Proof.
+      intros. pull not in *. tauto.
+    Qed.
+
+  End MSetLogicalFacts.
+  Import MSetLogicalFacts.
+
+  (** * Auxiliary Tactics
+      Again, these lemmas and tactics are in a module so that
+      they do not affect the namespace if you import the
+      enclosing module [Decide].  *)
+  Module MSetDecideAuxiliary.
+
+    (** ** Generic Tactics
+        We begin by defining a few generic, useful tactics. *)
+
+    (** [if t then t1 else t2] executes [t] and, if it does not
+        fail, then [t1] will be applied to all subgoals
+        produced.  If [t] fails, then [t2] is executed. *)
+    Tactic Notation
+      "if" tactic(t)
+      "then" tactic(t1)
+      "else" tactic(t2) :=
+      first [ t; first [ t1 | fail 2 ] | t2 ].
+
+    (** [prop P holds by t] succeeds (but does not modify the
+        goal or context) if the proposition [P] can be proved by
+        [t] in the current context.  Otherwise, the tactic
+        fails. *)
+    Tactic Notation "prop" constr(P) "holds" "by" tactic(t) :=
+      let H := fresh in
+      assert P as H by t;
+      clear H.
+
+    (** This tactic acts just like [assert ... by ...] but will
+        fail if the context already contains the proposition. *)
+    Tactic Notation "assert" "new" constr(e) "by" tactic(t) :=
+      match goal with
+      | H: e |- _ => fail 1
+      | _ => assert e by t
+      end.
+
+    (** [subst++] is similar to [subst] except that
+        - it never fails (as [subst] does on recursive
+          equations),
+        - it substitutes locally defined variable for their
+          definitions,
+        - it performs beta reductions everywhere, which may
+          arise after substituting a locally defined function
+          for its definition.
+        *)
+    Tactic Notation "subst" "++" :=
+      repeat (
+        match goal with
+        | x : _ |- _ => subst x
+        end);
+      cbv zeta beta in *.
+
+    (** [decompose records] calls [decompose record H] on every
+        relevant hypothesis [H]. *)
+    Tactic Notation "decompose" "records" :=
+      repeat (
+        match goal with
+        | H: _ |- _ => progress (decompose record H); clear H
+        end).
+
+    (** ** Discarding Irrelevant Hypotheses
+        We will want to clear the context of any
+        non-MSet-related hypotheses in order to increase the
+        speed of the tactic.  To do this, we will need to be
+        able to decide which are relevant.  We do this by making
+        a simple inductive definition classifying the
+        propositions of interest. *)
+
+    Inductive MSet_elt_Prop : Prop -> Prop :=
+    | eq_Prop : forall (S : Set) (x y : S),
+        MSet_elt_Prop (x = y)
+    | eq_elt_prop : forall x y,
+        MSet_elt_Prop (E.eq x y)
+    | In_elt_prop : forall x s,
+        MSet_elt_Prop (In x s)
+    | True_elt_prop :
+        MSet_elt_Prop True
+    | False_elt_prop :
+        MSet_elt_Prop False
+    | conj_elt_prop : forall P Q,
+        MSet_elt_Prop P ->
+        MSet_elt_Prop Q ->
+        MSet_elt_Prop (P /\ Q)
+    | disj_elt_prop : forall P Q,
+        MSet_elt_Prop P ->
+        MSet_elt_Prop Q ->
+        MSet_elt_Prop (P \/ Q)
+    | impl_elt_prop : forall P Q,
+        MSet_elt_Prop P ->
+        MSet_elt_Prop Q ->
+        MSet_elt_Prop (P -> Q)
+    | not_elt_prop : forall P,
+        MSet_elt_Prop P ->
+        MSet_elt_Prop (~ P).
+
+    Inductive MSet_Prop : Prop -> Prop :=
+    | elt_MSet_Prop : forall P,
+        MSet_elt_Prop P ->
+        MSet_Prop P
+    | Empty_MSet_Prop : forall s,
+        MSet_Prop (Empty s)
+    | Subset_MSet_Prop : forall s1 s2,
+        MSet_Prop (Subset s1 s2)
+    | Equal_MSet_Prop : forall s1 s2,
+        MSet_Prop (Equal s1 s2).
+
+    (** Here is the tactic that will throw away hypotheses that
+        are not useful (for the intended scope of the [fsetdec]
+        tactic). *)
+    Hint Constructors MSet_elt_Prop MSet_Prop : MSet_Prop.
+    Ltac discard_nonMSet :=
+      decompose records;
+      repeat (
+        match goal with
+        | H : ?P |- _ =>
+          if prop (MSet_Prop P) holds by
+            (auto 100 with MSet_Prop)
+          then fail
+          else clear H
+        end).
+
+    (** ** Turning Set Operators into Propositional Connectives
+        The lemmas from [MSetFacts] will be used to break down
+        set operations into propositional formulas built over
+        the predicates [In] and [E.eq] applied only to
+        variables.  We are going to use them with [autorewrite].
+        *)
+
+    Hint Rewrite
+      F.empty_iff F.singleton_iff F.add_iff F.remove_iff
+      F.union_iff F.inter_iff F.diff_iff
+    : set_simpl.
+
+    (** ** Decidability of MSet Propositions *)
+
+    (** [In] is decidable. *)
+    Lemma dec_In : forall x s,
+      decidable (In x s).
+    Proof.
+      red; intros; generalize (F.mem_iff s x); case (mem x s); intuition.
+    Qed.
+
+    (** [E.eq] is decidable. *)
+    Lemma dec_eq : forall (x y : E.t),
+      decidable (E.eq x y).
+    Proof.
+      red; intros x y; destruct (E.eq_dec x y); auto.
+    Qed.
+
+    (** The hint database [MSet_decidability] will be given to
+        the [push_neg] tactic from the module [Negation]. *)
+    Hint Resolve dec_In dec_eq : MSet_decidability.
+
+    (** ** Normalizing Propositions About Equality
+        We have to deal with the fact that [E.eq] may be
+        convertible with Coq's equality.  Thus, we will find the
+        following tactics useful to replace one form with the
+        other everywhere. *)
+
+    (** The next tactic, [Logic_eq_to_E_eq], mentions the term
+        [E.t]; thus, we must ensure that [E.t] is used in favor
+        of any other convertible but syntactically distinct
+        term. *)
+    Ltac change_to_E_t :=
+      repeat (
+        match goal with
+        | H : ?T |- _ =>
+          progress (change T with E.t in H);
+          repeat (
+            match goal with
+            | J : _ |- _ => progress (change T with E.t in J)
+            | |- _ => progress (change T with E.t)
+            end )
+        | H : forall x : ?T, _ |- _ =>
+          progress (change T with E.t in H);
+          repeat (
+            match goal with
+            | J : _ |- _ => progress (change T with E.t in J)
+            | |- _ => progress (change T with E.t)
+            end )
+       end).
+
+    (** These two tactics take us from Coq's built-in equality
+        to [E.eq] (and vice versa) when possible. *)
+
+    Ltac Logic_eq_to_E_eq :=
+      repeat (
+        match goal with
+        | H: _ |- _ =>
+          progress (change (@Logic.eq E.t) with E.eq in H)
+        | |- _ =>
+          progress (change (@Logic.eq E.t) with E.eq)
+        end).
+
+    Ltac E_eq_to_Logic_eq :=
+      repeat (
+        match goal with
+        | H: _ |- _ =>
+          progress (change E.eq with (@Logic.eq E.t) in H)
+        | |- _ =>
+          progress (change E.eq with (@Logic.eq E.t))
+        end).
+
+    (** This tactic works like the built-in tactic [subst], but
+        at the level of set element equality (which may not be
+        the convertible with Coq's equality). *)
+    Ltac substMSet :=
+      repeat (
+        match goal with
+        | H: E.eq ?x ?y |- _ => rewrite H in *; clear H
+        end).
+
+    (** ** Considering Decidability of Base Propositions
+        This tactic adds assertions about the decidability of
+        [E.eq] and [In] to the context.  This is necessary for
+        the completeness of the [fsetdec] tactic.  However, in
+        order to minimize the cost of proof search, we should be
+        careful to not add more than we need.  Once negations
+        have been pushed to the leaves of the propositions, we
+        only need to worry about decidability for those base
+        propositions that appear in a negated form. *)
+    Ltac assert_decidability :=
+      (** We actually don't want these rules to fire if the
+          syntactic context in the patterns below is trivially
+          empty, but we'll just do some clean-up at the
+          afterward.  *)
+      repeat (
+        match goal with
+        | H: context [~ E.eq ?x ?y] |- _ =>
+          assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq)
+        | H: context [~ In ?x ?s] |- _ =>
+          assert new (In x s \/ ~ In x s) by (apply dec_In)
+        | |- context [~ E.eq ?x ?y] =>
+          assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq)
+        | |- context [~ In ?x ?s] =>
+          assert new (In x s \/ ~ In x s) by (apply dec_In)
+        end);
+      (** Now we eliminate the useless facts we added (because
+          they would likely be very harmful to performance). *)
+      repeat (
+        match goal with
+        | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H
+        end).
+
+    (** ** Handling [Empty], [Subset], and [Equal]
+        This tactic instantiates universally quantified
+        hypotheses (which arise from the unfolding of [Empty],
+        [Subset], and [Equal]) for each of the set element
+        expressions that is involved in some membership or
+        equality fact.  Then it throws away those hypotheses,
+        which should no longer be needed. *)
+    Ltac inst_MSet_hypotheses :=
+      repeat (
+        match goal with
+        | H : forall a : E.t, _,
+          _ : context [ In ?x _ ] |- _ =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _
+          |- context [ In ?x _ ] =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _,
+          _ : context [ E.eq ?x _ ] |- _ =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _
+          |- context [ E.eq ?x _ ] =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _,
+          _ : context [ E.eq _ ?x ] |- _ =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _
+          |- context [ E.eq _ ?x ] =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        end);
+      repeat (
+        match goal with
+        | H : forall a : E.t, _ |- _ =>
+          clear H
+        end).
+
+    (** ** The Core [fsetdec] Auxiliary Tactics *)
+
+    (** Here is the crux of the proof search.  Recursion through
+        [intuition]!  (This will terminate if I correctly
+        understand the behavior of [intuition].) *)
+    Ltac fsetdec_rec :=
+      try (match goal with
+      | H: E.eq ?x ?x -> False |- _ => destruct H
+      end);
+      (reflexivity ||
+      contradiction ||
+      (progress substMSet; intuition fsetdec_rec)).
+
+    (** If we add [unfold Empty, Subset, Equal in *; intros;] to
+        the beginning of this tactic, it will satisfy the same
+        specification as the [fsetdec] tactic; however, it will
+        be much slower than necessary without the pre-processing
+        done by the wrapper tactic [fsetdec]. *)
+    Ltac fsetdec_body :=
+      inst_MSet_hypotheses;
+      autorewrite with set_simpl in *;
+      push not in * using MSet_decidability;
+      substMSet;
+      assert_decidability;
+      auto using (@Equivalence_Reflexive _ _ E.eq_equiv);
+      (intuition fsetdec_rec) ||
+      fail 1
+        "because the goal is beyond the scope of this tactic".
+
+  End MSetDecideAuxiliary.
+  Import MSetDecideAuxiliary.
+
+  (** * The [fsetdec] Tactic
+      Here is the top-level tactic (the only one intended for
+      clients of this library).  It's specification is given at
+      the top of the file. *)
+  Ltac fsetdec :=
+    (** We first unfold any occurrences of [iff]. *)
+    unfold iff in *;
+    (** We fold occurrences of [not] because it is better for
+        [intros] to leave us with a goal of [~ P] than a goal of
+        [False]. *)
+    fold any not; intros;
+    (** Now we decompose conjunctions, which will allow the
+        [discard_nonMSet] and [assert_decidability] tactics to
+        do a much better job. *)
+    decompose records;
+    discard_nonMSet;
+    (** We unfold these defined propositions on finite sets.  If
+        our goal was one of them, then have one more item to
+        introduce now. *)
+    unfold Empty, Subset, Equal in *; intros;
+    (** We now want to get rid of all uses of [=] in favor of
+        [E.eq].  However, the best way to eliminate a [=] is in
+        the context is with [subst], so we will try that first.
+        In fact, we may as well convert uses of [E.eq] into [=]
+        when possible before we do [subst] so that we can even
+        more mileage out of it.  Then we will convert all
+        remaining uses of [=] back to [E.eq] when possible.  We
+        use [change_to_E_t] to ensure that we have a canonical
+        name for set elements, so that [Logic_eq_to_E_eq] will
+        work properly.  *)
+    change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq;
+    (** The next optimization is to swap a negated goal with a
+        negated hypothesis when possible.  Any swap will improve
+        performance by eliminating the total number of
+        negations, but we will get the maximum benefit if we
+        swap the goal with a hypotheses mentioning the same set
+        element, so we try that first.  If we reach the fourth
+        branch below, we attempt any swap.  However, to maintain
+        completeness of this tactic, we can only perform such a
+        swap with a decidable proposition; hence, we first test
+        whether the hypothesis is an [MSet_elt_Prop], noting
+        that any [MSet_elt_Prop] is decidable. *)
+    pull not using MSet_decidability;
+    unfold not in *;
+    match goal with
+    | H: (In ?x ?r) -> False |- (In ?x ?s) -> False =>
+      contradict H; fsetdec_body
+    | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False =>
+      contradict H; fsetdec_body
+    | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False =>
+      contradict H; fsetdec_body
+    | H: ?P -> False |- ?Q -> False =>
+      if prop (MSet_elt_Prop P) holds by
+        (auto 100 with MSet_Prop)
+      then (contradict H; fsetdec_body)
+      else fsetdec_body
+    | |- _ =>
+      fsetdec_body
+    end.
+
+  (** * Examples *)
+
+  Module MSetDecideTestCases.
+
+    Lemma test_eq_trans_1 : forall x y z s,
+      E.eq x y ->
+      ~ ~ E.eq z y ->
+      In x s ->
+      In z s.
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_trans_2 : forall x y z r s,
+      In x (singleton y) ->
+      ~ In z r ->
+      ~ ~ In z (add y r) ->
+      In x s ->
+      In z s.
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_neq_trans_1 : forall w x y z s,
+      E.eq x w ->
+      ~ ~ E.eq x y ->
+      ~ E.eq y z ->
+      In w s ->
+      In w (remove z s).
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s,
+      In x (singleton w) ->
+      ~ In x r1 ->
+      In x (add y r1) ->
+      In y r2 ->
+      In y (remove z r2) ->
+      In w s ->
+      In w (remove z s).
+    Proof. fsetdec. Qed.
+
+    Lemma test_In_singleton : forall x,
+      In x (singleton x).
+    Proof. fsetdec. Qed.
+
+    Lemma test_add_In : forall x y s,
+      In x (add y s) ->
+      ~ E.eq x y ->
+      In x s.
+    Proof. fsetdec. Qed.
+
+    Lemma test_Subset_add_remove : forall x s,
+      s [<=] (add x (remove x s)).
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_disjunction : forall w x y z,
+      In w (add x (add y (singleton z))) ->
+      E.eq w x \/ E.eq w y \/ E.eq w z.
+    Proof. fsetdec. Qed.
+
+    Lemma test_not_In_disj : forall x y s1 s2 s3 s4,
+      ~ In x (union s1 (union s2 (union s3 (add y s4)))) ->
+      ~ (In x s1 \/ In x s4 \/ E.eq y x).
+    Proof. fsetdec. Qed.
+
+    Lemma test_not_In_conj : forall x y s1 s2 s3 s4,
+      ~ In x (union s1 (union s2 (union s3 (add y s4)))) ->
+      ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x.
+    Proof. fsetdec. Qed.
+
+    Lemma test_iff_conj : forall a x s s',
+    (In a s' <-> E.eq x a \/ In a s) ->
+    (In a s' <-> In a (add x s)).
+    Proof. fsetdec. Qed.
+
+    Lemma test_set_ops_1 : forall x q r s,
+      (singleton x) [<=] s ->
+      Empty (union q r) ->
+      Empty (inter (diff s q) (diff s r)) ->
+      ~ In x s.
+    Proof. fsetdec. Qed.
+
+    Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4,
+      Empty s1 ->
+      In x2 (add x1 s1) ->
+      In x3 s2 ->
+      ~ In x3 (remove x2 s2) ->
+      ~ In x4 s3 ->
+      In x4 (add x3 s3) ->
+      In x1 s4 ->
+      Subset (add x4 s4) s4.
+    Proof. fsetdec. Qed.
+
+    Lemma test_too_complex : forall x y z r s,
+      E.eq x y ->
+      (In x (singleton y) -> r [<=] s) ->
+      In z r ->
+      In z s.
+    Proof.
+      (** [fsetdec] is not intended to solve this directly. *)
+      intros until s; intros Heq H Hr; lapply H; fsetdec.
+    Qed.
+
+    Lemma function_test_1 :
+      forall (f : t -> t),
+      forall (g : elt -> elt),
+      forall (s1 s2 : t),
+      forall (x1 x2 : elt),
+      Equal s1 (f s2) ->
+      E.eq x1 (g (g x2)) ->
+      In x1 s1 ->
+      In (g (g x2)) (f s2).
+    Proof. fsetdec. Qed.
+
+    Lemma function_test_2 :
+      forall (f : t -> t),
+      forall (g : elt -> elt),
+      forall (s1 s2 : t),
+      forall (x1 x2 : elt),
+      Equal s1 (f s2) ->
+      E.eq x1 (g x2) ->
+      In x1 s1 ->
+      g x2 = g (g x2) ->
+      In (g (g x2)) (f s2).
+    Proof.
+      (** [fsetdec] is not intended to solve this directly. *)
+      intros until 3. intros g_eq. rewrite <- g_eq. fsetdec.
+    Qed.
+
+    Lemma test_baydemir :
+      forall (f : t -> t),
+      forall (s : t),
+      forall (x y : elt),
+      In x (add y (f s)) ->
+      ~ E.eq x y ->
+      In x (f s).
+    Proof.
+      fsetdec.
+    Qed.
+
+  End MSetDecideTestCases.
+
+End WDecideOn.
+
+Require Import MSetInterface.
+
+(** Now comes variants for self-contained weak sets and for full sets.
+    For these variants, only one argument is necessary. Thanks to
+    the subtyping [WS<=S], the [Decide] functor which is meant to be
+    used on modules [(M:S)] can simply be an alias of [WDecide]. *)
+
+Module WDecide (M:WSets) := WDecideOn M.E M.
+Module Decide := WDecide.
diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v
new file mode 100644
index 000000000..24eb77e62
--- /dev/null
+++ b/theories/MSets/MSetEqProperties.v
@@ -0,0 +1,937 @@
+(***********************************************************************)
+(*  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$ *)
+
+(** * 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 MSetProperties Zerob Sumbool Omega DecidableTypeEx.
+
+Module WEqPropertiesOn (Import E:DecidableType)(M:WSetsOn E).
+Module Import MP := WPropertiesOn E M.
+Import FM Dec.F.
+Import M.
+
+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 with set.
+Qed.
+
+Lemma is_empty_equal_empty: is_empty s = equal s empty.
+Proof.
+apply bool_1; split; intros.
+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 with set.
+Qed.
+
+Lemma choose_mem_2: choose s=None -> is_empty s=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma add_mem_1: mem x (add x s)=true.
+Proof.
+auto with set.
+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 with set.
+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 with set.
+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 with set.
+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 with set.
+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 MP.cardinal_1; simpl; auto with set.
+assert (cardinal s = 0) by (apply zerob_true_elim; auto).
+auto with set.
+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 eqb; destruct (E.eq_dec x y); intuition.
+Qed.
+
+Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y.
+Proof.
+intros; apply singleton_1; auto with set.
+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 with set.
+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 with set.
+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 principle *)
+
+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 set_induction; auto; intros.
+apply X with empty; auto with set.
+apply X with (add x s0); auto with set.
+apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto.
+apply X0; auto with set; apply mem_3; 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 mem_iff.
+destruct (mem x s); destruct (mem x s'); intuition.
+Qed.
+
+Section Fold.
+Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
+Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f).
+Variables (i:A).
+Variables (s s':t)(x:elt).
+
+Lemma fold_empty: (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 with set.
+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 with set.
+Qed.
+
+Lemma remove_fold_1:
+ mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i).
+Proof.
+intros; apply remove_fold_1 with (eqA:=eqA); auto with set.
+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 with set.
+Qed.
+
+Lemma remove_cardinal_2:
+ forall s x, mem x s=false -> cardinal (remove x s)=cardinal s.
+Proof.
+intros; apply Equal_cardinal; apply equal_2; 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 with set.
+Qed.
+
+Section Bool.
+
+(** Properties of [filter] *)
+
+Variable f:elt->bool.
+Variable Comp: Proper (E.eq==>Logic.eq) f.
+
+Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)).
+Proof.
+repeat red; 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 with set.
+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 with set.
+Qed.
+
+Lemma partition_filter_2:
+ forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true.
+Proof.
+auto with set.
+Qed.
+
+Lemma filter_add_1 : forall s x, f x = true ->
+ filter f (add x s) [=] add x (filter f s).
+Proof.
+red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff.
+intuition.
+rewrite <- H; apply Comp; auto.
+Qed.
+
+Lemma filter_add_2 : forall s x, f x = false ->
+ filter f (add x s) [=] filter f s.
+Proof.
+red; intros; do 2 (rewrite filter_iff; auto); set_iff.
+intuition.
+assert (f x = f a) by (apply Comp; auto).
+rewrite H in H1; rewrite H2 in H1; discriminate.
+Qed.
+
+Lemma add_filter_1 : forall s s' x,
+ 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.
+intuition.
+setoid_replace y with x; auto.
+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.
+intuition.
+setoid_replace x with a in H; auto. congruence.
+Qed.
+
+Lemma union_filter: forall f g,
+  Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.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 (Proper (E.eq==>Logic.eq) (fun x => orb (f x) (g x))).
+  repeat red; 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.
+
+Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s').
+Proof.
+unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto.
+Qed.
+
+(** Properties of [for_all] *)
+
+Lemma for_all_mem_1: forall s,
+ (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.
+rewrite <- negb_false_iff; 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.
+rewrite <- negb_true_iff; 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: Proper (E.eq==>Logic.eq) f.
+
+Let Comp' : Proper (E.eq==>Logic.eq) (fun x => negb (f x)).
+Proof.
+repeat red; 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.
+rewrite negb_true_iff; 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.
+rewrite negb_false_iff in H.
+rewrite <- negb_true_iff.
+apply for_all_mem_2 with (2:=H); 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.
+rewrite negb_true_iff.
+apply for_all_mem_3 with x;auto.
+rewrite negb_false_iff; 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.
+rewrite negb_true_iff in H.
+elim (@for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros;auto.
+elim p;intros.
+exists x;split;auto.
+rewrite <-negb_false_iff; 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.
+Notation compat_opL := (Proper (E.eq==>Logic.eq==>Logic.eq)).
+Notation transposeL := (transpose Logic.eq).
+
+Lemma sum_plus :
+  forall f g,
+  Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.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_opL (fun x:elt =>plus (f x))) by
+ (repeat red; intros; rewrite Hf; auto).
+assert (ft : transposeL (fun x:elt =>plus (f x))) by (red; intros; omega).
+assert (gc : compat_opL (fun x:elt => plus (g x))) by
+ (repeat red; intros; rewrite Hg; auto).
+assert (gt : transposeL (fun x:elt =>plus (g x))) by (red; intros; omega).
+assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))) by
+  (repeat red; intros; rewrite Hf,Hg; auto).
+assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))) by (red; intros; omega).
+intros s;pattern s; apply set_rec.
+intros.
+rewrite <- (fold_equal _ _ _ _ fc ft 0 _ _ H).
+rewrite <- (fold_equal _ _ _ _ gc gt 0 _ _ H).
+rewrite <- (fold_equal _ _ _ _ fgc fgt 0 _ _ H); auto.
+intros; do 3 (rewrite (fold_add _ _ _);auto).
+rewrite H0;simpl;omega.
+do 3 rewrite fold_empty;auto.
+Qed.
+
+Lemma sum_filter : forall f : elt -> bool, Proper (E.eq==>Logic.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 : Equivalence (@Logic.eq nat)) by (split; congruence).
+assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))) by
+ (repeat red; intros; rewrite Hf; auto).
+assert (ct : transposeL (fun x => plus (if f x then 1 else 0))) by
+ (red; intros; omega).
+intros s;pattern s; apply set_rec.
+intros.
+change elt with E.t.
+rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H).
+apply equal_2 in H; rewrite <- H, <-H0; 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;auto.
+rewrite MP.cardinal_1; auto.
+unfold Empty; intros.
+rewrite filter_iff; auto; set_iff; tauto.
+Qed.
+
+Lemma fold_compat :
+  forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)
+  (f g:elt->A->A),
+  Proper (E.eq==>eqA==>eqA) f -> transpose eqA f ->
+  Proper (E.eq==>eqA==>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.
+transitivity (fold f s0 i).
+apply fold_equal with (eqA:=eqA); auto.
+rewrite equal_sym; auto.
+transitivity (fold g s0 i).
+apply H0; intros; apply H1; auto with set.
+elim  (equal_2 H x); auto with set; intros.
+apply fold_equal with (eqA:=eqA); auto with set.
+transitivity (f x (fold f s0 i)).
+apply fold_add with (eqA:=eqA); auto with set.
+transitivity (g x (fold f s0 i)); auto with set.
+transitivity (g x (fold g s0 i)); auto with set.
+apply gc; auto with set.
+symmetry; apply fold_add with (eqA:=eqA); auto.
+do 2 rewrite fold_empty; reflexivity.
+Qed.
+
+Lemma sum_compat :
+  forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.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 _ (@Logic.eq nat));
+ repeat red; auto with *.
+Qed.
+
+End Sum.
+
+End WEqPropertiesOn.
+
+(** Now comes variants for self-contained weak sets and for full sets.
+    For these variants, only one argument is necessary. Thanks to
+    the subtyping [WS<=S], the [EqProperties] functor which is meant to be
+    used on modules [(M:S)] can simply be an alias of [WEqProperties]. *)
+
+Module WEqProperties (M:WSets) := WEqPropertiesOn M.E M.
+Module EqProperties := WEqProperties.
diff --git a/theories/MSets/MSetFacts.v b/theories/MSets/MSetFacts.v
new file mode 100644
index 000000000..2ba969217
--- /dev/null
+++ b/theories/MSets/MSetFacts.v
@@ -0,0 +1,527 @@
+(***********************************************************************)
+(*  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$ *)
+
+(** * Finite sets library *)
+
+(** This functor derives additional facts from [MSetInterface.S]. These
+  facts are mainly the specifications of [MSetInterface.S] written using
+  different styles: equivalence and boolean equalities.
+  Moreover, we prove that [E.Eq] and [Equal] are setoid equalities.
+*)
+
+Require Import DecidableTypeEx.
+Require Export MSetInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** First, a functor for Weak Sets in functorial version. *)
+
+Module WFactsOn (Import E : DecidableType)(Import M : WSetsOn E).
+
+Notation eq_dec := E.eq_dec.
+Definition eqb x y := if eq_dec x y then true else false.
+
+(** * Specifications written using implications :
+      this used to be the default interface. *)
+
+Section ImplSpec.
+Variable s s' : t.
+Variable x y : elt.
+
+Lemma In_1 : E.eq x y -> In x s -> In y s.
+Proof. intros E; rewrite E; auto. Qed.
+
+Lemma mem_1 : In x s -> mem x s = true.
+Proof. intros; apply <- mem_spec; auto. Qed.
+Lemma mem_2 : mem x s = true -> In x s.
+Proof. intros; apply -> mem_spec; auto. Qed.
+
+Lemma equal_1 : Equal s s' -> equal s s' = true.
+Proof. intros; apply <- equal_spec; auto. Qed.
+Lemma equal_2 : equal s s' = true -> Equal s s'.
+Proof. intros; apply -> equal_spec; auto. Qed.
+
+Lemma subset_1 : Subset s s' -> subset s s' = true.
+Proof. intros; apply <- subset_spec; auto. Qed.
+Lemma subset_2 : subset s s' = true -> Subset s s'.
+Proof. intros; apply -> subset_spec; auto. Qed.
+
+Lemma is_empty_1 : Empty s -> is_empty s = true.
+Proof. intros; apply <- is_empty_spec; auto. Qed.
+Lemma is_empty_2 : is_empty s = true -> Empty s.
+Proof. intros; apply -> is_empty_spec; auto. Qed.
+
+Lemma add_1 : E.eq x y -> In y (add x s).
+Proof. intros; apply <- add_spec; auto. Qed.
+Lemma add_2 : In y s -> In y (add x s).
+Proof. intros; apply <- add_spec; auto. Qed.
+Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s.
+Proof. rewrite add_spec. intros H [H'|H']; auto. elim H; auto. Qed.
+
+Lemma remove_1 : E.eq x y -> ~ In y (remove x s).
+Proof. intros; rewrite remove_spec; intuition. Qed.
+Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
+Proof. intros; apply <- remove_spec; auto. Qed.
+Lemma remove_3 : In y (remove x s) -> In y s.
+Proof. rewrite remove_spec; intuition. Qed.
+
+Lemma singleton_1 : In y (singleton x) -> E.eq x y.
+Proof. rewrite singleton_spec; auto. Qed.
+Lemma singleton_2 : E.eq x y -> In y (singleton x).
+Proof. rewrite singleton_spec; auto. Qed.
+
+Lemma union_1 : In x (union s s') -> In x s \/ In x s'.
+Proof. rewrite union_spec; auto. Qed.
+Lemma union_2 : In x s -> In x (union s s').
+Proof. rewrite union_spec; auto. Qed.
+Lemma union_3 : In x s' -> In x (union s s').
+Proof. rewrite union_spec; auto. Qed.
+
+Lemma inter_1 : In x (inter s s') -> In x s.
+Proof. rewrite inter_spec; intuition. Qed.
+Lemma inter_2 : In x (inter s s') -> In x s'.
+Proof. rewrite inter_spec; intuition. Qed.
+Lemma inter_3 : In x s -> In x s' -> In x (inter s s').
+Proof. rewrite inter_spec; intuition. Qed.
+
+Lemma diff_1 : In x (diff s s') -> In x s.
+Proof. rewrite diff_spec; intuition. Qed.
+Lemma diff_2 : In x (diff s s') -> ~ In x s'.
+Proof. rewrite diff_spec; intuition. Qed.
+Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s').
+Proof. rewrite diff_spec; auto. Qed.
+
+Variable f : elt -> bool.
+Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).
+
+Lemma filter_1 : compatb f -> In x (filter f s) -> In x s.
+Proof. intros P; rewrite filter_spec; intuition. Qed.
+Lemma filter_2 : compatb f -> In x (filter f s) -> f x = true.
+Proof. intros P; rewrite filter_spec; intuition. Qed.
+Lemma filter_3 : compatb f -> In x s -> f x = true -> In x (filter f s).
+Proof. intros P; rewrite filter_spec; intuition. Qed.
+
+Lemma for_all_1 : compatb f ->
+      For_all (fun x => f x = true) s -> for_all f s = true.
+Proof. intros; apply <- for_all_spec; auto. Qed.
+Lemma for_all_2 : compatb f ->
+      for_all f s = true -> For_all (fun x => f x = true) s.
+Proof. intros; apply -> for_all_spec; auto. Qed.
+
+Lemma exists_1 : compatb f ->
+      Exists (fun x => f x = true) s -> exists_ f s = true.
+Proof. intros; apply <- exists_spec; auto. Qed.
+
+Lemma exists_2 : compatb f ->
+      exists_ f s = true -> Exists (fun x => f x = true) s.
+Proof. intros; apply -> exists_spec; auto. Qed.
+
+Lemma elements_1 : In x s -> InA E.eq x (elements s).
+Proof. intros; apply <- elements_spec1; auto. Qed.
+Lemma elements_2 : InA E.eq x (elements s) -> In x s.
+Proof. intros; apply -> elements_spec1; auto. Qed.
+
+End ImplSpec.
+
+Notation empty_1 := empty_spec (only parsing).
+Notation fold_1 := fold_spec (only parsing).
+Notation cardinal_1 := cardinal_spec (only parsing).
+Notation partition_1 := partition_spec1 (only parsing).
+Notation partition_2 := partition_spec2 (only parsing).
+Notation choose_1 := choose_spec1 (only parsing).
+Notation choose_2 := choose_spec2 (only parsing).
+Notation elements_3w := elements_spec2w (only parsing).
+
+Hint Resolve mem_1 equal_1 subset_1 empty_1
+    is_empty_1 choose_1 choose_2 add_1 add_2 remove_1
+    remove_2 singleton_2 union_1 union_2 union_3
+    inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1
+    partition_1 partition_2 elements_1 elements_3w
+    : set.
+Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3
+    remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2
+    filter_1 filter_2 for_all_2 exists_2 elements_2
+    : set.
+
+
+(** * Specifications written using equivalences :
+      this is now provided by the default interface. *)
+
+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.
+intros E; rewrite E; intuition.
+Qed.
+
+Lemma mem_iff : In x s <-> mem x s = true.
+Proof. apply iff_sym, mem_spec. Qed.
+
+Lemma not_mem_iff : ~In x s <-> mem x s = false.
+Proof.
+rewrite <-mem_spec; destruct (mem x s); intuition.
+Qed.
+
+Lemma equal_iff : s[=]s' <-> equal s s' = true.
+Proof. apply iff_sym, equal_spec. Qed.
+
+Lemma subset_iff : s[<=]s' <-> subset s s' = true.
+Proof. apply iff_sym, subset_spec. Qed.
+
+Lemma empty_iff : In x empty <-> False.
+Proof. intuition; apply (empty_spec H). Qed.
+
+Lemma is_empty_iff : Empty s <-> is_empty s = true.
+Proof. apply iff_sym, is_empty_spec. Qed.
+
+Lemma singleton_iff : In y (singleton x) <-> E.eq x y.
+Proof. rewrite singleton_spec; intuition. Qed.
+
+Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s.
+Proof. rewrite add_spec; intuition. Qed.
+
+Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s)  <-> In y s).
+Proof. rewrite add_spec; intuition. elim H; auto. Qed.
+
+Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y.
+Proof. rewrite remove_spec; intuition. Qed.
+
+Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s).
+Proof. rewrite remove_spec; intuition. Qed.
+
+Variable f : elt -> bool.
+
+Lemma for_all_iff : Proper (E.eq==>Logic.eq) f ->
+  (For_all (fun x => f x = true) s <-> for_all f s = true).
+Proof. intros; apply iff_sym, for_all_spec; auto. Qed.
+
+Lemma exists_iff : Proper (E.eq==>Logic.eq) f ->
+  (Exists (fun x => f x = true) s <-> exists_ f s = true).
+Proof. intros; apply iff_sym, exists_spec; auto. Qed.
+
+Lemma elements_iff : In x s <-> InA E.eq x (elements s).
+Proof. apply iff_sym, elements_spec1. Qed.
+
+End IffSpec.
+
+Notation union_iff := union_spec (only parsing).
+Notation inter_iff := inter_spec (only parsing).
+Notation diff_iff := diff_spec (only parsing).
+Notation filter_iff := filter_spec (only parsing).
+
+(** 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 empty_b : mem y empty = false.
+Proof.
+generalize (empty_iff y)(mem_iff empty y).
+destruct (mem y empty); intuition.
+Qed.
+
+Lemma add_b : mem y (add x s) = eqb x y || mem y s.
+Proof.
+generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition.
+Qed.
+
+Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s.
+Proof.
+intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H).
+destruct (mem y s); destruct (mem y (add x s)); intuition.
+Qed.
+
+Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y).
+Proof.
+generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition.
+Qed.
+
+Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s.
+Proof.
+intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H).
+destruct (mem y s); destruct (mem y (remove x s)); intuition.
+Qed.
+
+Lemma singleton_b : mem y (singleton x) = eqb x y.
+Proof.
+generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y (singleton x)); intuition.
+Qed.
+
+Lemma union_b : mem x (union s s') = mem x s || mem x s'.
+Proof.
+generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition.
+Qed.
+
+Lemma inter_b : mem x (inter s s') = mem x s && mem x s'.
+Proof.
+generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition.
+Qed.
+
+Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s').
+Proof.
+generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition.
+Qed.
+
+Lemma elements_b : mem x s = existsb (eqb x) (elements s).
+Proof.
+generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)).
+rewrite InA_alt.
+destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros.
+symmetry.
+rewrite H1.
+destruct H0 as (H0,_).
+destruct H0 as (a,(Ha1,Ha2)); [ intuition |].
+exists a; intuition.
+unfold eqb; destruct (eq_dec x a); auto.
+rewrite <- H.
+rewrite H0.
+destruct H1 as (H1,_).
+destruct H1 as (a,(Ha1,Ha2)); [intuition|].
+exists a; intuition.
+unfold eqb in *; destruct (eq_dec x a); auto; discriminate.
+Qed.
+
+Variable f : elt->bool.
+
+Lemma filter_b : Proper (E.eq==>Logic.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 : Proper (E.eq==>Logic.eq) f ->
+  for_all f s = forallb f (elements s).
+Proof.
+intros.
+generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s).
+unfold For_all.
+destruct (forallb f (elements s)); destruct (for_all f s); auto; intros.
+rewrite <- H1; intros.
+destruct H0 as (H0,_).
+rewrite (H2 x0) in H3.
+rewrite (InA_alt E.eq x0 (elements s)) in H3.
+destruct H3 as (a,(Ha1,Ha2)).
+rewrite (H _ _ Ha1).
+apply H0; auto.
+symmetry.
+rewrite H0; intros.
+destruct H1 as (_,H1).
+apply H1; auto.
+rewrite H2.
+rewrite InA_alt; eauto.
+Qed.
+
+Lemma exists_b : Proper (E.eq==>Logic.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; split; auto.
+rewrite H2; rewrite InA_alt; eauto.
+symmetry.
+rewrite H0.
+destruct H1 as (_,H1).
+destruct H1 as (a,(Ha1,Ha2)); auto.
+rewrite (H2 a) in Ha1.
+rewrite (InA_alt E.eq a (elements s)) in Ha1.
+destruct Ha1 as (b,(Hb1,Hb2)).
+exists b; auto.
+rewrite <- (H _ _ Hb1); auto.
+Qed.
+
+End BoolSpec.
+
+(** * Declarations of morphisms with respects to [E.eq] and [Equal] *)
+
+Instance In_m : Proper (E.eq==>Equal==>iff) In.
+Proof.
+unfold Equal; intros x y H s s' H0.
+rewrite (In_eq_iff s H); auto.
+Qed.
+
+Instance Empty_m : Proper (Equal==>iff) Empty.
+Proof.
+repeat red; unfold Empty; intros s s' E.
+setoid_rewrite E; auto.
+Qed.
+
+Instance is_empty_m : Proper (Equal==>Logic.eq) is_empty.
+Proof.
+intros s s' H.
+generalize (is_empty_iff s). rewrite H at 1. rewrite is_empty_iff.
+destruct (is_empty s); destruct (is_empty s'); intuition.
+Qed.
+
+Instance mem_m : Proper (E.eq==>Equal==>Logic.eq) mem.
+Proof.
+intros x x' Hx s s' Hs.
+generalize (mem_iff s x). rewrite Hs, Hx at 1; rewrite mem_iff.
+destruct (mem x s); destruct (mem x' s'); intuition.
+Qed.
+
+Instance singleton_m : Proper (E.eq==>Equal) singleton.
+Proof.
+intros x y H a.
+rewrite !singleton_iff; split; intros; etransitivity; eauto.
+Qed.
+
+Instance add_m : Proper (E.eq==>Equal==>Equal) add.
+Proof.
+intros x x' Hx s s' Hs a. rewrite !add_iff, Hx, Hs; intuition.
+Qed.
+
+Instance remove_m : Proper (E.eq==>Equal==>Equal) remove.
+Proof.
+intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx, Hs; intuition.
+Qed.
+
+Instance union_m : Proper (Equal==>Equal==>Equal) union.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition.
+Qed.
+
+Instance inter_m : Proper (Equal==>Equal==>Equal) inter.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition.
+Qed.
+
+Instance diff_m : Proper (Equal==>Equal==>Equal) diff.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition.
+Qed.
+
+Instance Subset_m : Proper (Equal==>Equal==>iff) Subset.
+Proof.
+unfold Equal, Subset; firstorder.
+Qed.
+
+Instance subset_m : Proper (Equal==>Equal==>Logic.eq) subset.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2.
+generalize (subset_iff s1 s2). rewrite Hs1, Hs2 at 1. rewrite subset_iff.
+destruct (subset s1 s2); destruct (subset s1' s2'); intuition.
+Qed.
+
+Instance equal_m : Proper (Equal==>Equal==>Logic.eq) equal.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2.
+generalize (equal_iff s1 s2). rewrite Hs1,Hs2 at 1. rewrite equal_iff.
+destruct (equal s1 s2); destruct (equal s1' s2'); intuition.
+Qed.
+
+Instance SubsetSetoid : PreOrder Subset. (* reflexive + transitive *)
+Proof. firstorder. Qed.
+
+Definition Subset_refl := @PreOrder_Reflexive _ _ SubsetSetoid.
+Definition Subset_trans := @PreOrder_Transitive _ _ SubsetSetoid.
+
+Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> impl) In | 1.
+Proof.
+  simpl_relation. eauto with set.
+Qed.
+
+Instance Empty_s_m : Proper (Subset-->impl) Empty.
+Proof. firstorder. Qed.
+
+Instance add_s_m : Proper (E.eq==>Subset++>Subset) add.
+Proof.
+intros x x' Hx s s' Hs a. rewrite !add_iff, Hx; intuition.
+Qed.
+
+Instance remove_s_m : Proper (E.eq==>Subset++>Subset) remove.
+Proof.
+intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx; intuition.
+Qed.
+
+Instance union_s_m : Proper (Subset++>Subset++>Subset) union.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition.
+Qed.
+
+Instance inter_s_m : Proper (Subset++>Subset++>Subset) inter.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition.
+Qed.
+
+Instance diff_s_m : Proper (Subset++>Subset-->Subset) diff.
+Proof.
+intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition.
+Qed.
+
+
+(* [fold], [filter], [for_all], [exists_] and [partition] requires
+  some knowledge on [f] in order to be known as morphisms. *)
+
+Instance filter_equal `(Proper _ (E.eq==>Logic.eq) f) :
+ Proper (Equal==>Equal) (filter f).
+Proof.
+intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition.
+Qed.
+
+Instance filter_subset `(Proper _ (E.eq==>Logic.eq) f) :
+ Proper (Subset==>Subset) (filter f).
+Proof.
+intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition.
+Qed.
+
+Lemma filter_ext : forall f f', Proper (E.eq==>Logic.eq) f -> (forall x, f x = f' x) ->
+ forall s s', s[=]s' -> filter f s [=] filter f' s'.
+Proof.
+intros f f' Hf Hff' s s' Hss' x. rewrite 2 filter_iff; auto.
+rewrite Hff', Hss'; intuition.
+red; red; intros; rewrite <- 2 Hff'; auto.
+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 WFactsOn.
+
+(** Now comes variants for self-contained weak sets and for full sets.
+    For these variants, only one argument is necessary. Thanks to
+    the subtyping [WS<=S], the [Facts] functor which is meant to be
+    used on modules [(M:S)] can simply be an alias of [WFacts]. *)
+
+Module WFacts (M:WSets) := WFactsOn M.E M.
+Module Facts := WFacts.
diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v
new file mode 100644
index 000000000..630da6302
--- /dev/null
+++ b/theories/MSets/MSetInterface.v
@@ -0,0 +1,944 @@
+(***********************************************************************)
+(*  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$ *)
+
+(** * Finite set library *)
+
+(** Set interfaces, inspired by the one of Ocaml. When compared with
+    Ocaml, the main differences are:
+    - the lack of [iter] function, useless since Coq is purely functional
+    - the use of [option] types instead of [Not_found] exceptions
+    - the use of [nat] instead of [int] for the [cardinal] function
+
+    Several variants of the set interfaces are available:
+    - [WSetsOn] : functorial signature for weak sets
+    - [WSets]   : self-contained version of [WSets]
+    - [SetsOn]  : functorial signature for ordered sets
+    - [Sets]    : self-contained version of [Sets]
+    - [WRawSets] : a signature for weak sets that may be ill-formed
+    - [RawSets]  : same for ordered sets
+
+    If unsure, [S = Sets] is probably what you're looking for: most other
+    signatures are subsets of it, while [Sets] can be obtained from
+    [RawSets] via the use of a subset type (see (W)Raw2Sets below).
+*)
+
+Require Export Bool OrderedType2 DecidableType2.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module Type WOps (E : DecidableType).
+
+  Definition elt := E.t.
+
+  Parameter t : Type. (** 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]. *)
+
+  Parameter fold : forall A : Type, (elt -> A -> A) -> t -> A -> A.
+  (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
+  where [x1 ... xN] are the elements of [s].
+  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. *)
+
+  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 [None] if
+  the set is empty. Which element is chosen is unspecified.
+  Equal sets could return different elements. *)
+
+End WOps.
+
+
+
+
+(** ** Functorial signature for weak sets
+
+    Weak sets are sets without ordering on base elements, only
+    a decidable equality. *)
+
+Module Type WSetsOn (E : DecidableType).
+  (** First, we ask for all the functions *)
+  Include Type WOps E.
+
+  (** Logical predicates *)
+  Parameter In : elt -> t -> Prop.
+  Instance In_compat : Proper (E.eq==>eq==>iff) 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 := 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).
+
+  Definition eq : t -> t -> Prop := Equal.
+  Instance eq_equiv : Equivalence eq. (* obvious, for subtyping only *)
+  Parameter eq_dec : forall s s', { eq s s' } + { ~ eq s s' }.
+
+  (** Specifications of set operators *)
+
+  Section Spec.
+  Variable s s': t.
+  Variable x y : elt.
+  Variable f : elt -> bool.
+  Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).
+
+  Parameter mem_spec : mem x s = true <-> In x s.
+  Parameter equal_spec : equal s s' = true <-> s[=]s'.
+  Parameter subset_spec : subset s s' = true <-> s[<=]s'.
+  Parameter empty_spec : Empty empty.
+  Parameter is_empty_spec : is_empty s = true <-> Empty s.
+  Parameter add_spec : In y (add x s) <-> E.eq y x \/ In y s.
+  Parameter remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x.
+  Parameter singleton_spec : In y (singleton x) <-> E.eq y x.
+  Parameter union_spec : In x (union s s') <-> In x s \/ In x s'.
+  Parameter inter_spec : In x (inter s s') <-> In x s /\ In x s'.
+  Parameter diff_spec : In x (diff s s') <-> In x s /\ ~In x s'.
+  Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A),
+    fold f s i = fold_left (flip f) (elements s) i.
+  Parameter cardinal_spec : cardinal s = length (elements s).
+  Parameter filter_spec : compatb f ->
+    (In x (filter f s) <-> In x s /\ f x = true).
+  Parameter for_all_spec : compatb f ->
+    (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Parameter exists_spec : compatb f ->
+    (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Parameter partition_spec1 : compatb f ->
+    fst (partition f s) [=] filter f s.
+  Parameter partition_spec2 : compatb f ->
+    snd (partition f s) [=] filter (fun x => negb (f x)) s.
+  Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s.
+  (** When compared with ordered sets, here comes the only
+      property that is really weaker: *)
+  Parameter elements_spec2w : NoDupA E.eq (elements s).
+  Parameter choose_spec1 : choose s = Some x -> In x s.
+  Parameter choose_spec2 : choose s = None -> Empty s.
+
+  End Spec.
+
+End WSetsOn.
+
+(** ** Static signature for weak sets
+
+    Similar to the functorial signature [WSetsOn], except that the
+    module [E] of base elements is incorporated in the signature. *)
+
+Module Type WSets.
+  Declare Module E : DecidableType.
+  Include Type WSetsOn E.
+End WSets.
+
+(** ** Functorial signature for sets on ordered elements
+
+    Based on [WSetsOn], plus ordering on sets and [min_elt] and [max_elt]
+    and some stronger specifications for other functions. *)
+
+Module Type SetsOn (E : OrderedType).
+  Include Type WSetsOn E.
+
+  Parameter compare : t -> t -> comparison.
+  (** Total ordering between sets. Can be used as the ordering function
+  for doing sets of sets. *)
+
+  Parameter min_elt : t -> option elt.
+  (** Return the smallest element of the given set
+  (with respect to the [E.compare] ordering),
+  or [None] if the set is empty. *)
+
+  Parameter max_elt : t -> option elt.
+  (** Same as [min_elt], but returns the largest element of the
+  given set. *)
+
+  Parameter lt : t -> t -> Prop.
+
+  (** Specification of [lt] *)
+  Instance lt_strorder : StrictOrder lt.
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+
+  Section Spec.
+  Variable s s': t.
+  Variable x y : elt.
+
+  Parameter compare_spec : Cmp eq lt (compare s s') s s'.
+
+  (** Additional specification of [elements] *)
+  Parameter elements_spec2 : sort E.lt (elements s).
+
+  (** Remark: since [fold] is specified via [elements], this stronger
+   specification of [elements] has an indirect impact on [fold],
+   which can now be proved to receive elements in increasing order.
+  *)
+
+  Parameter min_elt_spec1 : min_elt s = Some x -> In x s.
+  Parameter min_elt_spec2 : min_elt s = Some x -> In y s -> ~ E.lt y x.
+  Parameter min_elt_spec3 : min_elt s = None -> Empty s.
+
+  Parameter max_elt_spec1 : max_elt s = Some x -> In x s.
+  Parameter max_elt_spec2 : max_elt s = Some x -> In y s -> ~ E.lt x y.
+  Parameter max_elt_spec3 : max_elt s = None -> Empty s.
+
+  (** Additional specification of [choose] *)
+  Parameter choose_spec3 : choose s = Some x -> choose s' = Some y ->
+    Equal s s' -> E.eq x y.
+
+  End Spec.
+
+End SetsOn.
+
+
+(** ** Static signature for sets on ordered elements
+
+    Similar to the functorial signature [SetsOn], except that the
+    module [E] of base elements is incorporated in the signature. *)
+
+Module Type Sets.
+  Declare Module E : OrderedType.
+  Include Type SetsOn E.
+End Sets.
+
+Module Type S := Sets.
+
+
+(** ** Some subtyping tests
+<<
+WSetsOn ---> WSets
+ |           |
+ |           |
+ V           V
+SetsOn  ---> Sets
+
+Module S_WS (M : Sets) <: WSets := M.
+Module Sfun_WSfun (E:OrderedType)(M : SetsOn E) <: WSetsOn E := M.
+Module S_Sfun (M : Sets) <: SetsOn M.E := M.
+Module WS_WSfun (M : WSets) <: WSetsOn M.E := M.
+>>
+*)
+
+
+
+(** ** Signatures for set representations with ill-formed values.
+
+   Motivation:
+
+   For many implementation of finite sets (AVL trees, sorted
+   lists, lists without duplicates), we use the same two-layer
+   approach:
+
+   - A first module deals with the datatype (eg. list or tree) without
+   any restriction on the values we consider. In this module (named
+   "Raw" in the past), some results are stated under the assumption
+   that some invariant (e.g. sortedness) holds for the input sets. We
+   also prove that this invariant is preserved by set operators.
+
+   - A second module implements the exact Sets interface by
+   using a subtype, for instance [{ l : list A | sorted l }].
+   This module is a mere wrapper around the first Raw module.
+
+   With the interfaces below, we give some respectability to
+   the "Raw" modules. This allows the interested users to directly
+   access them via the interfaces. Even better, we can build once
+   and for all a functor doing the transition between Raw and usual Sets.
+
+   Description:
+
+   The type [t] of sets may contain ill-formed values on which our
+   set operators may give wrong answers. In particular, [mem]
+   may not see a element in a ill-formed set (think for instance of a
+   unsorted list being given to an optimized [mem] that stops
+   its search as soon as a strictly larger element is encountered).
+
+   Unlike optimized operators, the [In] predicate is supposed to
+   always be correct, even on ill-formed sets. Same for [Equal] and
+   other logical predicates.
+
+   A predicate parameter [Ok] is used to discriminate between
+   well-formed and ill-formed values. Some lemmas hold only on sets
+   validating [Ok]. This predicate [Ok] is required to be
+   preserved by set operators. Moreover, a boolean function [isok]
+   should exist for identifying (at least some of) the well-formed sets.
+
+*)
+
+
+Module Type WRawSets (E : DecidableType).
+  (** First, we ask for all the functions *)
+  Include Type WOps E.
+
+  (** Is a set well-formed or ill-formed ? *)
+
+  Parameter IsOk : t -> Prop.
+  Class Ok (s:t) : Prop := { ok : IsOk s }.
+
+  (** In order to be able to validate (at least some) particular sets as
+      well-formed, we ask for a boolean function for (semi-)deciding
+      predicate [Ok]. If [Ok] isn't decidable, [isok] may be the
+      always-false function. *)
+  Parameter isok : t -> bool.
+  Instance isok_Ok `(isok s = true) : Ok s | 10.
+
+  (** Logical predicates *)
+  Parameter In : elt -> t -> Prop.
+  Instance In_compat : Proper (E.eq==>eq==>iff) 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 := 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).
+
+  Definition eq : t -> t -> Prop := Equal.
+  Instance eq_equiv : Equivalence eq.
+
+  (** First, all operations are compatible with the well-formed predicate. *)
+
+  Instance empty_ok : Ok empty.
+  Instance add_ok s x `(Ok s) : Ok (add x s).
+  Instance remove_ok s x `(Ok s) : Ok (remove x s).
+  Instance singleton_ok x : Ok (singleton x).
+  Instance union_ok s s' `(Ok s, Ok s') : Ok (union s s').
+  Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s').
+  Instance diff_ok s s' `(Ok s, Ok s') : Ok (diff s s').
+  Instance filter_ok s f `(Ok s) : Ok (filter f s).
+  Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)).
+  Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)).
+
+  (** Now, the specifications, with constraints on the input sets. *)
+
+  Section Spec.
+  Variable s s': t.
+  Variable x y : elt.
+  Variable f : elt -> bool.
+  Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).
+
+  Parameter mem_spec : forall `{Ok s}, mem x s = true <-> In x s.
+  Parameter equal_spec : forall `{Ok s, Ok s'},
+    equal s s' = true <-> s[=]s'.
+  Parameter subset_spec : forall `{Ok s, Ok s'},
+    subset s s' = true <-> s[<=]s'.
+  Parameter empty_spec : Empty empty.
+  Parameter is_empty_spec : is_empty s = true <-> Empty s.
+  Parameter add_spec : forall `{Ok s},
+    In y (add x s) <-> E.eq y x \/ In y s.
+  Parameter remove_spec : forall `{Ok s},
+    In y (remove x s) <-> In y s /\ ~E.eq y x.
+  Parameter singleton_spec : In y (singleton x) <-> E.eq y x.
+  Parameter union_spec : forall `{Ok s, Ok s'},
+    In x (union s s') <-> In x s \/ In x s'.
+  Parameter inter_spec : forall `{Ok s, Ok s'},
+    In x (inter s s') <-> In x s /\ In x s'.
+  Parameter diff_spec : forall `{Ok s, Ok s'},
+    In x (diff s s') <-> In x s /\ ~In x s'.
+  Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A),
+    fold f s i = fold_left (flip f) (elements s) i.
+  Parameter cardinal_spec : forall `{Ok s},
+    cardinal s = length (elements s).
+  Parameter filter_spec : compatb f ->
+    (In x (filter f s) <-> In x s /\ f x = true).
+  Parameter for_all_spec : compatb f ->
+    (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Parameter exists_spec : compatb f ->
+    (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Parameter partition_spec1 : compatb f ->
+    fst (partition f s) [=] filter f s.
+  Parameter partition_spec2 : compatb f ->
+    snd (partition f s) [=] filter (fun x => negb (f x)) s.
+  Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s.
+  Parameter elements_spec2w : forall `{Ok s}, NoDupA E.eq (elements s).
+  Parameter choose_spec1 : choose s = Some x -> In x s.
+  Parameter choose_spec2 : choose s = None -> Empty s.
+
+  End Spec.
+
+(*
+ BUG ?! When the Instance *_ok were under a section,
+   this re-export was mandatory !! BUG in Global Instance ?
+ Hint Resolve empty_ok add_ok remove_ok union_ok inter_ok
+  diff_ok singleton_ok filter_ok partition_ok1 partition_ok2
+  : typeclass_instances.
+*)
+
+End WRawSets.
+
+(** From weak raw sets to weak usual sets *)
+
+Module WRaw2Sets (E:DecidableType)(M:WRawSets E) <: WSets with Module E := E.
+
+ Module E := E.
+ Definition elt := E.t.
+
+ Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}.
+ Definition t := t_.
+ Implicit Arguments Mkt [ [is_ok] ].
+ Hint Resolve is_ok : typeclass_instances.
+
+ Definition In x s := M.In 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 mem x (s : t) := M.mem x s.
+ Definition add x (s : t) := Mkt (M.add x s).
+ Definition remove x (s : t) := Mkt (M.remove x s).
+ Definition singleton x := Mkt (M.singleton x).
+ Definition union (s s' : t) := Mkt (M.union s s').
+ Definition inter (s s' : t) := Mkt (M.inter s s').
+ Definition diff (s s' : t) := Mkt (M.diff s s').
+ Definition equal (s s' : t) := M.equal s s'.
+ Definition subset (s s' : t) := M.subset s s'.
+ Definition empty := Mkt M.empty.
+ Definition is_empty (s : t) := M.is_empty s.
+ Definition elements (s : t) := M.elements s.
+ Definition choose (s : t) := M.choose s.
+ Definition fold (A : Type) f (s : t) : A -> A := M.fold f s.
+ Definition cardinal (s : t) := M.cardinal s.
+ Definition filter f (s : t) := Mkt (M.filter f s).
+ Definition for_all f (s : t) := M.for_all f s.
+ Definition exists_ f (s : t) := M.exists_ f s.
+ Definition partition f (s : t) :=
+   let p := M.partition f s in (Mkt (fst p), Mkt (snd p)).
+
+ Instance In_compat : Proper (E.eq==>eq==>iff) In.
+ Proof. repeat red. intros; apply M.In_compat; congruence. Qed.
+
+ Definition eq : t -> t -> Prop := Equal.
+
+ Instance eq_equiv : Equivalence eq.
+ Proof. firstorder. Qed.
+
+ Definition eq_dec : forall (s s':t), { eq s s' }+{ ~eq s s' }.
+ Proof.
+  intros (s,Hs) (s',Hs').
+  change ({M.Equal s s'}+{~M.Equal s s'}).
+  destruct (M.equal s s') as [ ]_eqn:H; [left|right];
+   rewrite <- M.equal_spec; congruence.
+ Defined.
+
+
+ Section Spec.
+  Variable s s' : t.
+  Variable x y : elt.
+  Variable f : elt -> bool.
+  Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing).
+
+  Lemma mem_spec : mem x s = true <-> In x s.
+  Proof. exact (@M.mem_spec _ _ _). Qed.
+  Lemma equal_spec : equal s s' = true <-> Equal s s'.
+  Proof. exact (@M.equal_spec _ _ _ _). Qed.
+  Lemma subset_spec : subset s s' = true <-> Subset s s'.
+  Proof. exact (@M.subset_spec _ _ _ _). Qed.
+  Lemma empty_spec : Empty empty.
+  Proof. exact M.empty_spec. Qed.
+  Lemma is_empty_spec : is_empty s = true <-> Empty s.
+  Proof. exact (@M.is_empty_spec _). Qed.
+  Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s.
+  Proof. exact (@M.add_spec _ _ _ _). Qed.
+  Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x.
+  Proof. exact (@M.remove_spec _ _ _ _). Qed.
+  Lemma singleton_spec : In y (singleton x) <-> E.eq y x.
+  Proof. exact (@M.singleton_spec _ _). Qed.
+  Lemma union_spec : In x (union s s') <-> In x s \/ In x s'.
+  Proof. exact (@M.union_spec _ _ _ _ _). Qed.
+  Lemma inter_spec : In x (inter s s') <-> In x s /\ In x s'.
+  Proof. exact (@M.inter_spec _ _ _ _ _). Qed.
+  Lemma diff_spec : In x (diff s s') <-> In x s /\ ~In x s'.
+  Proof. exact (@M.diff_spec _ _ _ _ _). Qed.
+  Lemma fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof. exact (@M.fold_spec _). Qed.
+  Lemma cardinal_spec : cardinal s = length (elements s).
+  Proof. exact (@M.cardinal_spec s _). Qed.
+  Lemma filter_spec : compatb f ->
+    (In x (filter f s) <-> In x s /\ f x = true).
+  Proof. exact (@M.filter_spec _ _ _). Qed.
+  Lemma for_all_spec : compatb f ->
+    (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Proof. exact (@M.for_all_spec _ _). Qed.
+  Lemma exists_spec : compatb f ->
+    (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Proof. exact (@M.exists_spec _ _). Qed.
+  Lemma partition_spec1 : compatb f -> Equal (fst (partition f s)) (filter f s).
+  Proof. exact (@M.partition_spec1 _ _). Qed.
+  Lemma partition_spec2 : compatb f ->
+      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof. exact (@M.partition_spec2 _ _). Qed.
+  Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s.
+  Proof. exact (@M.elements_spec1 _ _). Qed.
+  Lemma elements_spec2w : NoDupA E.eq (elements s).
+  Proof. exact (@M.elements_spec2w _ _). Qed.
+  Lemma choose_spec1 : choose s = Some x -> In x s.
+  Proof. exact (@M.choose_spec1 _ _). Qed.
+  Lemma choose_spec2 : choose s = None -> Empty s.
+  Proof. exact (@M.choose_spec2 _). Qed.
+
+ End Spec.
+
+End WRaw2Sets.
+
+(** Same approach for ordered sets *)
+
+Module Type RawSets (E : OrderedType).
+  Include Type WRawSets E.
+
+  Parameter compare : t -> t -> comparison.
+  Parameter min_elt : t -> option elt.
+  Parameter max_elt : t -> option elt.
+  Parameter lt : t -> t -> Prop.
+
+  (** Specification of [lt] *)
+  Instance lt_strorder : StrictOrder lt.
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+
+  Section Spec.
+  Variable s s': t.
+  Variable x y : elt.
+
+  (** Specification of [compare] *)
+  Parameter compare_spec : forall `{Ok s, Ok s'}, Cmp eq lt (compare s s') s s'.
+
+  (** Additional specification of [elements] *)
+  Parameter elements_spec2 : forall `{Ok s}, sort E.lt (elements s).
+
+  (** Specification of [min_elt] *)
+  Parameter min_elt_spec1 : min_elt s = Some x -> In x s.
+  Parameter min_elt_spec2 : forall `{Ok s}, min_elt s = Some x -> In y s -> ~ E.lt y x.
+  Parameter min_elt_spec3 : min_elt s = None -> Empty s.
+
+  (** Specification of [max_elt] *)
+  Parameter max_elt_spec1 : max_elt s = Some x -> In x s.
+  Parameter max_elt_spec2 : forall `{Ok s}, max_elt s = Some x -> In y s -> ~ E.lt x y.
+  Parameter max_elt_spec3 : max_elt s = None -> Empty s.
+
+  (** Additional specification of [choose] *)
+  Parameter choose_spec3 : forall `{Ok s, Ok s'},
+    choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y.
+
+  End Spec.
+
+End RawSets.
+
+(** From Raw to usual sets *)
+
+Module Raw2Sets (O:OrderedType)(M:RawSets O) <: S with Module E := O.
+  Include WRaw2Sets O M.
+
+  Definition compare (s s':t) := M.compare s s'.
+  Definition min_elt (s:t) := M.min_elt s.
+  Definition max_elt (s:t) := M.max_elt s.
+  Definition lt (s s':t) := M.lt s s'.
+
+  (** Specification of [lt] *)
+  Instance lt_strorder : StrictOrder lt.
+  Proof.
+  unfold lt; split; repeat red.
+  intros s; eapply StrictOrder_Irreflexive; eauto.
+  intros s s' s''; eapply StrictOrder_Transitive; eauto.
+  Qed.
+
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+  Proof.
+  repeat red. unfold eq, lt.
+  intros (s1,p1) (s2,p2) E (s1',p1') (s2',p2') E'; simpl.
+  change (M.eq s1 s2) in E.
+  change (M.eq s1' s2') in E'.
+  rewrite E,E'; intuition.
+  Qed.
+
+  Section Spec.
+  Variable s s' s'' : t.
+  Variable x y : elt.
+
+  Lemma compare_spec : Cmp eq lt (compare s s') s s'.
+  Proof.
+   generalize (@M.compare_spec s s' _ _).
+   unfold compare; destruct M.compare; auto.
+  Qed.
+
+  (** Additional specification of [elements] *)
+  Lemma elements_spec2 : sort O.lt (elements s).
+  Proof. exact (@M.elements_spec2 _ _). Qed.
+
+  (** Specification of [min_elt] *)
+  Lemma min_elt_spec1 : min_elt s = Some x -> In x s.
+  Proof. exact (@M.min_elt_spec1 _ _). Qed.
+  Lemma min_elt_spec2 : min_elt s = Some x -> In y s -> ~ O.lt y x.
+  Proof. exact (@M.min_elt_spec2 _ _ _ _). Qed.
+  Lemma min_elt_spec3 : min_elt s = None -> Empty s.
+  Proof. exact (@M.min_elt_spec3 _). Qed.
+
+  (** Specification of [max_elt] *)
+  Lemma max_elt_spec1 : max_elt s = Some x -> In x s.
+  Proof. exact (@M.max_elt_spec1 _ _). Qed.
+  Lemma max_elt_spec2 : max_elt s = Some x -> In y s -> ~ O.lt x y.
+  Proof. exact (@M.max_elt_spec2 _ _ _ _). Qed.
+  Lemma max_elt_spec3 : max_elt s = None -> Empty s.
+  Proof. exact (@M.max_elt_spec3 _). Qed.
+
+  (** Additional specification of [choose] *)
+  Lemma choose_spec3 :
+    choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y.
+  Proof. exact (@M.choose_spec3 _ _ _ _ _ _). Qed.
+
+  End Spec.
+
+End Raw2Sets.
+
+
+(** It is in fact possible to provide an ordering on sets with
+    very little information on them (more or less only the [In]
+    predicate). This generic build of ordering is in fact not
+    used for the moment, we rather use a simplier version
+    dedicated to sets-as-sorted-lists, see [MakeListOrdering].
+*)
+
+Module Type IN (O:OrderedType).
+ Parameter Inline t : Type.
+ Parameter Inline In : O.t -> t -> Prop.
+ Instance In_compat : Proper (O.eq==>eq==>iff) In.
+ Definition Equal s s' := forall x, In x s <-> In x s'.
+ Definition Empty s := forall x, ~In x s.
+End IN.
+
+Module MakeSetOrdering (O:OrderedType)(Import M:IN O).
+ Module Import MO := OrderedTypeFacts O.
+
+ Definition eq : t -> t -> Prop := Equal.
+
+ Instance eq_equiv : Equivalence eq.
+ Proof. firstorder. Qed.
+
+ Instance : Proper (O.eq==>eq==>iff) In.
+ Proof.
+ intros x x' Ex s s' Es. rewrite Ex. apply Es.
+ Qed.
+
+ Definition Below x s := forall y, In y s -> O.lt y x.
+ Definition Above x s := forall y, In y s -> O.lt x y.
+
+ Definition EquivBefore x s s' :=
+   forall y, O.lt y x -> (In y s <-> In y s').
+
+ Definition EmptyBetween x y s :=
+   forall z, In z s -> O.lt z y -> O.lt z x.
+
+ Definition lt s s' := exists x, EquivBefore x s s' /\
+   ((In x s' /\ Below x s) \/
+    (In x s  /\ exists y, In y s' /\ O.lt x y /\ EmptyBetween x y s')).
+
+ Instance : Proper (O.eq==>eq==>eq==>iff) EquivBefore.
+ Proof.
+  unfold EquivBefore. intros x x' E s1 s1' E1 s2 s2' E2.
+  setoid_rewrite E; setoid_rewrite E1; setoid_rewrite E2; intuition.
+ Qed.
+
+ Instance : Proper (O.eq==>eq==>iff) Below.
+ Proof.
+  unfold Below. intros x x' Ex s s' Es.
+  setoid_rewrite Ex; setoid_rewrite Es; intuition.
+ Qed.
+
+ Instance : Proper (O.eq==>eq==>iff) Above.
+ Proof.
+  unfold Above. intros x x' Ex s s' Es.
+  setoid_rewrite Ex; setoid_rewrite Es; intuition.
+ Qed.
+
+ Instance : Proper (O.eq==>O.eq==>eq==>iff) EmptyBetween.
+ Proof.
+  unfold EmptyBetween. intros x x' Ex y y' Ey s s' Es.
+  setoid_rewrite Ex; setoid_rewrite Ey; setoid_rewrite Es; intuition.
+ Qed.
+
+ Instance lt_compat : Proper (eq==>eq==>iff) lt.
+ Proof.
+  unfold lt. intros s1 s1' E1 s2 s2' E2.
+  setoid_rewrite E1; setoid_rewrite E2; intuition.
+ Qed.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+  split.
+  (* irreflexive *)
+  intros s (x & _ & [(IN,Em)|(IN & y & IN' & LT & Be)]).
+  specialize (Em x IN); order.
+  specialize (Be x IN LT); order.
+  (* transitive *)
+  intros s1 s2 s3 (x & EQ & [(IN,Pre)|(IN,Lex)])
+                  (x' & EQ' & [(IN',Pre')|(IN',Lex')]).
+  (* 1) Pre / Pre --> Pre *)
+  assert (O.lt x x') by (specialize (Pre' x IN); auto).
+  exists x; split.
+  intros y Hy; rewrite <- (EQ' y); auto; order.
+  left; split; auto.
+  rewrite <- (EQ' x); auto.
+  (* 2) Pre / Lex *)
+  elim_compare x x'; intros Hxx'.
+  (* 2a) x=x' --> Pre *)
+  destruct Lex' as (y & INy & LT & Be).
+  exists y; split.
+  intros z Hz. split; intros INz.
+   specialize (Pre z INz). rewrite <- (EQ' z), <- (EQ z); auto; order.
+   specialize (Be z INz Hz). rewrite (EQ z), (EQ' z); auto; order.
+  left; split; auto.
+  intros z Hz. transitivity x; auto; order.
+  (* 2b) x<x' --> Pre *)
+  exists x; split.
+  intros z Hz. rewrite <- (EQ' z) by order; auto.
+  left; split; auto.
+  rewrite <- (EQ' x); auto.
+  (* 2c) x>x' --> Lex *)
+  exists x'; split.
+  intros z Hz. rewrite (EQ z) by order; auto.
+  right; split; auto.
+  rewrite (EQ x'); auto.
+  (* 3) Lex / Pre --> Lex *)
+  destruct Lex as (y & INy & LT & Be).
+  specialize (Pre' y INy).
+  exists x; split.
+  intros z Hz. rewrite <- (EQ' z) by order; auto.
+  right; split; auto.
+  exists y; repeat split; auto.
+  rewrite <- (EQ' y); auto.
+  intros z Hz LTz; apply Be; auto. rewrite (EQ' z); auto; order.
+  (* 4) Lex / Lex *)
+  elim_compare x x'; intros Hxx'.
+  (* 4a) x=x' --> impossible *)
+  destruct Lex as (y & INy & LT & Be).
+  rewrite Hxx' in LT; specialize (Be x' IN' LT); order.
+  (* 4b) x<x' --> Lex *)
+  exists x; split.
+  intros z Hz. rewrite <- (EQ' z) by order; auto.
+  right; split; auto.
+  destruct Lex as (y & INy & LT & Be).
+  elim_compare y x'; intros Hyx'.
+   (* 4ba *)
+   destruct Lex' as (y' & Iny' & LT' & Be').
+   exists y'; repeat split; auto. order.
+   intros z Hz LTz. specialize (Be' z Hz LTz).
+    rewrite <- (EQ' z) in Hz by order.
+    apply Be; auto. order.
+   (* 4bb *)
+   exists y; repeat split; auto.
+   rewrite <- (EQ' y); auto.
+   intros z Hz LTz. apply Be; auto. rewrite (EQ' z); auto; order.
+   (* 4bc*)
+   specialize (Be x' IN' Hyx'); order.
+  (* 4c) x>x' --> Lex *)
+  exists x'; split.
+  intros z Hz. rewrite (EQ z) by order; auto.
+  right; split; auto.
+  rewrite (EQ x'); auto.
+ Qed.
+
+ Lemma lt_empty_r : forall s s', Empty s' -> ~ lt s s'.
+ Proof.
+  intros s s' Hs' (x & _ & [(IN,_)|(_ & y & IN & _)]).
+  elim (Hs' x IN).
+  elim (Hs' y IN).
+ Qed.
+
+ Definition Add x s s' := forall y, In y s' <-> O.eq x y \/ In y s.
+
+ Lemma lt_empty_l : forall x s1 s2 s2',
+  Empty s1 -> Above x s2 -> Add x s2 s2' -> lt s1 s2'.
+ Proof.
+  intros x s1 s2 s2' Em Ab Ad.
+  exists x; split.
+  intros y Hy; split; intros IN.
+  elim (Em y IN).
+  rewrite (Ad y) in IN; destruct IN as [EQ|IN]. order.
+  specialize (Ab y IN). order.
+  left; split.
+  rewrite (Ad x); auto.
+  intros y Hy. elim (Em y Hy).
+ Qed.
+
+ Lemma lt_add_lt : forall x1 x2 s1 s1' s2 s2',
+   Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' ->
+   O.lt x1 x2 -> lt s1' s2'.
+  Proof.
+  intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 LT.
+  exists x1; split; [ | right; split]; auto.
+  intros y Hy. rewrite (Ad1 y), (Ad2 y).
+  split; intros [U|U]; try order.
+  specialize (Ab1 y U). order.
+  specialize (Ab2 y U). order.
+  rewrite (Ad1 x1); auto.
+  exists x2; repeat split; auto.
+  rewrite (Ad2 x2); auto.
+  intros y. rewrite (Ad2 y). intros [U|U]. order.
+  specialize (Ab2 y U). order.
+  Qed.
+
+  Lemma lt_add_eq : forall x1 x2 s1 s1' s2 s2',
+   Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' ->
+   O.eq x1 x2 -> lt s1 s2 -> lt s1' s2'.
+  Proof.
+  intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 Hx (x & EQ & Disj).
+  assert (O.lt x1 x).
+   destruct Disj as [(IN,_)|(IN,_)]; auto. rewrite Hx; auto.
+  exists x; split.
+  intros z Hz. rewrite (Ad1 z), (Ad2 z).
+  split; intros [U|U]; try order.
+  right; rewrite <- (EQ z); auto.
+  right; rewrite (EQ z); auto.
+  destruct Disj as [(IN,Em)|(IN & y & INy & LTy & Be)].
+  left; split; auto.
+  rewrite (Ad2 x); auto.
+  intros z. rewrite (Ad1 z); intros [U|U]; try specialize (Ab1 z U); order.
+  right; split; auto.
+  rewrite (Ad1 x); auto.
+  exists y; repeat split; auto.
+  rewrite (Ad2 y); auto.
+  intros z. rewrite (Ad2 z). intros [U|U]; try specialize (Ab2 z U); order.
+  Qed.
+
+End MakeSetOrdering.
+
+
+Module MakeListOrdering (O:OrderedType).
+ Module MO:=OrderedTypeFacts O.
+
+ Notation t := (list O.t).
+ Notation In := (InA O.eq).
+
+ Definition eq s s' := forall x, In x s <-> In x s'.
+
+ Instance eq_equiv : Equivalence eq.
+
+ Inductive lt_list : t -> t -> Prop :=
+    | lt_nil : forall x s, lt_list nil (x :: s)
+    | lt_cons_lt : forall x y s s',
+        O.lt x y -> lt_list (x :: s) (y :: s')
+    | lt_cons_eq : forall x y s s',
+        O.eq x y -> lt_list s s' -> lt_list (x :: s) (y :: s').
+ Hint Constructors lt_list.
+
+ Definition lt := lt_list.
+ Hint Unfold lt.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+ split.
+ (* irreflexive *)
+ assert (forall s s', s=s' -> ~lt s s').
+  red; induction 2.
+  discriminate.
+  inversion H; subst.
+  apply (StrictOrder_Irreflexive y); auto.
+  inversion H; subst; auto.
+ intros s Hs; exact (H s s (eq_refl s) Hs).
+ (* transitive *)
+ 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 2. transitivity x'; auto.
+ constructor 2. rewrite <- H0; auto.
+ intros.
+ inversion_clear H3.
+ constructor 2. rewrite H0; auto.
+ constructor 3; auto. transitivity y; auto. unfold lt in *; auto.
+ Qed.
+
+ Instance lt_compat' :
+  Proper (eqlistA O.eq==>eqlistA O.eq==>iff) lt.
+ Proof.
+ apply proper_sym_impl_iff_2; auto with *.
+ intros s1 s1' E1 s2 s2' E2 H.
+ revert s1' E1 s2' E2.
+ induction H; intros; inversion_clear E1; inversion_clear E2.
+ constructor 1.
+ constructor 2. MO.order.
+ constructor 3. MO.order. unfold lt in *; auto.
+ Qed.
+
+ Lemma eq_cons :
+  forall l1 l2 x y,
+  O.eq x y -> eq l1 l2 -> eq (x :: l1) (y :: l2).
+ Proof.
+  unfold eq; intros l1 l2 x y Exy E12 z.
+  split; inversion_clear 1.
+  left; MO.order. right; rewrite <- E12; auto.
+  left; MO.order. right; rewrite E12; auto.
+ Qed.
+ Hint Resolve eq_cons.
+
+ Lemma cons_Cmp : forall c x1 x2 l1 l2, O.eq x1 x2 ->
+  Cmp eq lt c l1 l2 -> Cmp eq lt c (x1::l1) (x2::l2).
+ Proof.
+  destruct c; simpl; unfold flip; auto.
+ Qed.
+ Hint Resolve cons_Cmp.
+
+End MakeListOrdering.
diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v
new file mode 100644
index 000000000..2b7dbb586
--- /dev/null
+++ b/theories/MSets/MSetList.v
@@ -0,0 +1,866 @@
+(***********************************************************************)
+(*  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$ *)
+
+(** * Finite sets library *)
+
+(** This file proposes an implementation of the non-dependant
+    interface [MSetInterface.S] using strictly ordered list. *)
+
+Require Export MSetInterface.
+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 Ops (X:OrderedType) <: WOps X.
+
+  Definition elt := X.t.
+  Definition t := list elt.
+
+  Definition empty : t := nil.
+
+  Definition is_empty (l : t) := if l then true else false.
+
+  (** ** The set operations. *)
+
+  Fixpoint mem x s :=
+    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 s :=
+    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) := x :: nil.
+
+  Fixpoint remove x s :=
+    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' :=
+    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.
+
+  Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B :=
+    fold_left (flip f) s i.
+
+  Fixpoint filter (f : elt -> bool) (s : t) : 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) : 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) : 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) : 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.
+
+  Fixpoint compare s s' :=
+   match s, s' with
+    | nil, nil => Eq
+    | nil, _ => Lt
+    | _, nil => Gt
+    | x::s, x'::s' =>
+      match X.compare x x' with
+       | Eq => compare s s'
+       | Lt => Lt
+       | Gt => Gt
+      end
+   end.
+
+End Ops.
+
+Module MakeRaw (X: OrderedType) <: RawSets X.
+  Module Import MX := OrderedTypeFacts X.
+
+  Include Ops X.
+
+  (** ** Proofs of set operation specifications. *)
+
+  Section ForNotations.
+
+  Notation Sort := (sort X.lt).
+  Notation Inf := (lelistA X.lt).
+  Notation In := (InA X.eq).
+
+  Definition IsOk := Sort.
+
+  Class Ok (s:t) : Prop := { ok : Sort s }.
+
+  Hint Resolve @ok.
+  Hint Constructors Ok.
+
+  Instance Sort_Ok `(Hs : Sort s) : Ok s := Hs.
+
+  Ltac inv_ok := match goal with
+   | H:Ok (_ :: _) |- _ => apply @ok in H; inversion_clear H; inv_ok
+   | H:Ok nil |- _ => clear H; inv_ok
+   | H:Sort ?l |- _ => generalize (Build_Ok H); clear H; intro H; inv_ok
+   | _ => idtac
+  end.
+
+  Ltac inv := invlist InA; inv_ok; invlist lelistA.
+  Ltac constructors := repeat constructor.
+
+  Ltac sort_inf_in := match goal with
+   | H:Inf ?x ?l, H':In ?y ?l |- _ =>
+     cut (X.lt x y); [ intro | apply Sort_Inf_In with l; auto]
+   | _ => fail
+  end.
+
+  Definition inf x l :=
+   match l with
+   | nil => true
+   | y::_ => match X.compare x y with Lt => true | _ => false end
+   end.
+
+  Fixpoint isok l :=
+   match l with
+   | nil => true
+   | x::l => inf x l && isok l
+   end.
+
+  Lemma inf_iff : forall x l, Inf x l <-> inf x l = true.
+  Proof.
+  induction l as [ | y l IH].
+  simpl; split; auto.
+  simpl.
+  elim_compare x y; intuition; try discriminate.
+  inv; order.
+  inv; order.
+  Qed.
+
+  Lemma isok_iff : forall l, Ok l <-> isok l = true.
+  Proof.
+  induction l as [ | x l IH].
+  simpl; split; auto; constructor.
+  simpl.
+  rewrite andb_true_iff, <- inf_iff, <- IH.
+  split.
+  intros; inv; auto.
+  constructor; intuition.
+  Qed.
+
+  Global Instance isok_Ok `(isok s = true) : Ok s | 10.
+  Proof.
+  intros. apply <- isok_iff. auto.
+  Qed.
+
+  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_spec :
+   forall (s : t) (x : elt) (Hs : Ok s), mem x s = true <-> In x s.
+  Proof.
+  induction s; intros; inv; simpl.
+  intuition. discriminate. inv.
+  elim_compare x a; intros; rewrite InA_cons; intuition; try order.
+  discriminate.
+  sort_inf_in. order.
+  rewrite <- IHs; auto.
+  rewrite IHs; 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.
+  intros; elim_compare x a; intros; inv; intuition.
+  Qed.
+  Hint Resolve add_inf.
+
+  Global Instance add_ok s x `(Ok s) : Ok (add x s).
+  Proof.
+  simple induction s; simpl.
+  intuition.
+  intros; elim_compare x a; intros; inv; auto.
+  Qed.
+
+  Lemma add_spec :
+   forall (s : t) (x y : elt) (Hs : Ok s),
+    In y (add x s) <-> X.eq y x \/ In y s.
+  Proof.
+  induction s; simpl; intros.
+  intuition. inv; auto.
+  elim_compare x a; intros; inv; rewrite !InA_cons, ?IHs; intuition.
+  left; order.
+  Qed.
+
+  Lemma remove_inf :
+   forall (s : t) (x a : elt) (Hs : Ok s), Inf a s -> Inf a (remove x s).
+  Proof.
+  induction s; simpl.
+  intuition.
+  intros; elim_compare x a; intros; inv; auto.
+  apply Inf_lt with a; auto.
+  Qed.
+  Hint Resolve remove_inf.
+
+  Global Instance remove_ok s x `(Ok s) : Ok (remove x s).
+  Proof.
+  induction s; simpl.
+  intuition.
+  intros; elim_compare x a; intros; inv; auto.
+  Qed.
+
+  Lemma remove_spec :
+   forall (s : t) (x y : elt) (Hs : Ok s),
+    In y (remove x s) <-> In y s /\ ~X.eq y x.
+  Proof.
+  induction s; simpl; intros.
+  intuition; inv; auto.
+  elim_compare x a; intros; inv; rewrite !InA_cons, ?IHs; intuition;
+   try sort_inf_in; try order.
+  Qed.
+
+  Global Instance singleton_ok x : Ok (singleton x).
+  Proof.
+  unfold singleton; simpl; auto.
+  Qed.
+
+  Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x.
+  Proof.
+  unfold singleton; simpl; split; intros; inv; auto.
+  Qed.
+
+  Ltac induction2 :=
+    simple induction s;
+     [ simpl; auto; try solve [ intros; inv ]
+     | intros x l Hrec; simple induction s';
+        [ simpl; auto; try solve [ intros; inv ]
+        | intros x' l' Hrec'; simpl; elim_compare x x'; intros; inv; auto ]].
+
+  Lemma union_inf :
+   forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'),
+   Inf a s -> Inf a s' -> Inf a (union s s').
+  Proof.
+  induction2.
+  Qed.
+  Hint Resolve union_inf.
+
+  Global Instance union_ok s s' `(Ok s, Ok s') : Ok (union s s').
+  Proof.
+  induction2; constructors; try apply @ok; auto.
+  apply Inf_eq with x'; auto; apply union_inf; auto; apply Inf_eq with x; auto.
+  change (Inf x' (union (x :: l) l')); auto.
+  Qed.
+
+  Lemma union_spec :
+   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
+   In x (union s s') <-> In x s \/ In x s'.
+  Proof.
+  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto.
+  left; order.
+  Qed.
+
+  Lemma inter_inf :
+   forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'),
+   Inf a s -> Inf a s' -> Inf a (inter s s').
+  Proof.
+  induction2.
+  apply Inf_lt with x; auto.
+  apply Hrec'; auto.
+  apply Inf_lt with x'; auto.
+  Qed.
+  Hint Resolve inter_inf.
+
+  Global Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s').
+  Proof.
+  induction2.
+  constructors; auto.
+  apply Inf_eq with x'; auto; apply inter_inf; auto; apply Inf_eq with x; auto.
+  Qed.
+
+  Lemma inter_spec :
+   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
+   In x (inter s s') <-> In x s /\ In x s'.
+  Proof.
+  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto;
+   try sort_inf_in; try order.
+  Qed.
+
+  Lemma diff_inf :
+   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s') (a : elt),
+   Inf a s -> Inf a s' -> Inf a (diff s s').
+  Proof.
+  induction2.
+  apply Hrec; trivial.
+  apply Inf_lt with x; auto.
+  apply Inf_lt with x'; auto.
+  apply Hrec'; auto.
+  apply Inf_lt with x'; auto.
+  Qed.
+  Hint Resolve diff_inf.
+
+  Global Instance diff_ok s s' `(Ok s, Ok s') : Ok (diff s s').
+  Proof.
+  induction2. constructors; auto. apply @ok; auto.
+  Qed.
+
+  Lemma diff_spec :
+   forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'),
+   In x (diff s s') <-> In x s /\ ~In x s'.
+  Proof.
+  induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto;
+   try sort_inf_in; try order.
+  right; intuition; inv; order.
+  Qed.
+
+  Lemma equal_spec :
+   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'),
+   equal s s' = true <-> Equal s s'.
+  Proof.
+  induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl.
+  intuition.
+  split; intros H. discriminate. assert (In x' nil) by (rewrite H; auto). inv.
+  split; intros H. discriminate. assert (In x nil) by (rewrite <-H; auto). inv.
+  inv.
+  elim_compare x x'; intros C; try discriminate.
+  (* x=x' *)
+  rewrite IH; auto.
+  split; intros E y; specialize (E y).
+  rewrite !InA_cons, E, C; intuition.
+  rewrite !InA_cons, C in E. intuition; try sort_inf_in; order.
+  (* x<x' *)
+  split; intros E. discriminate.
+  assert (In x (x'::s')) by (rewrite <- E; auto).
+  inv; try sort_inf_in; order.
+  (* x>x' *)
+  split; intros E. discriminate.
+  assert (In x' (x::s)) by (rewrite E; auto).
+  inv; try sort_inf_in; order.
+  Qed.
+
+  Lemma subset_spec :
+   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'),
+   subset s s' = true <-> Subset s s'.
+  Proof.
+  intros s s'; revert s.
+  induction s' as [ | x' s' IH]; intros [ | x s] Hs Hs'; simpl; auto.
+  split; try red; intros; auto.
+  split; intros H. discriminate. assert (In x nil) by (apply H; auto). inv.
+  split; try red; intros; auto. inv.
+  inv. elim_compare x x'; intros C.
+  (* x=x' *)
+  rewrite IH; auto.
+  split; intros S y; specialize (S y).
+  rewrite !InA_cons, C. intuition.
+  rewrite !InA_cons, C in S. intuition; try sort_inf_in; order.
+  (* x<x' *)
+  split; intros S. discriminate.
+  assert (In x (x'::s')) by (apply S; auto).
+  inv; try sort_inf_in; order.
+  (* x>x' *)
+  rewrite IH; auto.
+  split; intros S y; specialize (S y).
+  rewrite !InA_cons. intuition.
+  rewrite !InA_cons in S. rewrite !InA_cons. intuition; try sort_inf_in; order.
+  Qed.
+
+  Global Instance empty_ok : Ok empty.
+  Proof.
+  constructors.
+  Qed.
+
+  Lemma empty_spec : Empty empty.
+  Proof.
+  unfold Empty, empty; intuition; inv.
+  Qed.
+
+  Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s.
+  Proof.
+  intros [ | x s]; simpl.
+  split; auto. intros _ x H. inv.
+  split. discriminate. intros H. elim (H x); auto.
+  Qed.
+
+  Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s.
+  Proof.
+  intuition.
+  Qed.
+
+  Lemma elements_spec2 : forall (s : t) (Hs : Ok s), Sort (elements s).
+  Proof.
+  auto.
+  Qed.
+
+  Lemma elements_spec2w : forall (s : t) (Hs : Ok s), NoDupA X.eq (elements s).
+  Proof.
+  auto.
+  Qed.
+
+  Lemma min_elt_spec1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s.
+  Proof.
+  destruct s; simpl; inversion 1; auto.
+  Qed.
+
+  Lemma min_elt_spec2 :
+   forall (s : t) (x y : elt) (Hs : Ok s),
+   min_elt s = Some x -> In y s -> ~ X.lt y x.
+  Proof.
+  induction s as [ | x s IH]; simpl; inversion 2; subst.
+  intros; inv; try sort_inf_in; order.
+  Qed.
+
+  Lemma min_elt_spec3 : forall s : t, min_elt s = None -> Empty s.
+  Proof.
+  destruct s; simpl; red; intuition. inv. discriminate.
+  Qed.
+
+  Lemma max_elt_spec1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s.
+  Proof.
+  induction s as [ | x s IH]. inversion 1.
+  destruct s as [ | y s]. simpl. inversion 1; subst; auto.
+  right; apply IH; auto.
+  Qed.
+
+  Lemma max_elt_spec2 :
+   forall (s : t) (x y : elt) (Hs : Ok s),
+   max_elt s = Some x -> In y s -> ~ X.lt x y.
+  Proof.
+  induction s as [ | a s IH]. inversion 2.
+  destruct s as [ | b s]. inversion 2; subst. intros; inv; order.
+  intros. inv; auto.
+  assert (~X.lt x b) by (apply IH; auto).
+  assert (X.lt a b) by auto.
+  order.
+  Qed.
+
+  Lemma max_elt_spec3 : forall s : t, max_elt s = None -> Empty s.
+  Proof.
+  induction s as [ | a s IH]. red; intuition; inv.
+  destruct s as [ | b s]. inversion 1.
+  intros; elim IH with b; auto.
+  Qed.
+
+  Definition choose_spec1 :
+    forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_spec1.
+
+  Definition choose_spec2 :
+    forall s : t, choose s = None -> Empty s := min_elt_spec3.
+
+  Lemma choose_spec3: forall s s' x x', Ok s -> Ok s' ->
+   choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'.
+  Proof.
+   unfold choose; intros s s' x x' Hs Hs' Hx Hx' H.
+   assert (~X.lt x x').
+    apply min_elt_spec2 with s'; auto.
+    rewrite <-H; auto using min_elt_spec1.
+   assert (~X.lt x' x).
+    apply min_elt_spec2 with s; auto.
+    rewrite H; auto using min_elt_spec1.
+   order.
+  Qed.
+
+  Lemma fold_spec :
+   forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
+   fold f s i = fold_left (flip f) (elements s) i.
+  Proof.
+  reflexivity.
+  Qed.
+
+  Lemma cardinal_spec :
+   forall (s : t) (Hs : Ok s),
+   cardinal s = length (elements s).
+  Proof.
+  auto.
+  Qed.
+
+  Lemma filter_inf :
+   forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s),
+   Inf x s -> Inf x (filter f s).
+  Proof.
+  simple induction s; simpl.
+  intuition.
+  intros x l Hrec a f Hs Ha; inv.
+  case (f x); auto.
+  apply Hrec; auto.
+  apply Inf_lt with x; auto.
+  Qed.
+
+  Global Instance filter_ok s f `(Ok s) : Ok (filter f s).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec f Hs; inv.
+  case (f x); auto.
+  constructors; auto.
+  apply filter_inf; auto.
+  Qed.
+
+  Lemma filter_spec :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   (In x (filter f s) <-> In x s /\ f x = true).
+  Proof.
+  induction s; simpl; intros.
+  split; intuition; inv.
+  destruct (f a) as [ ]_eqn:F; rewrite !InA_cons, ?IHs; intuition.
+  setoid_replace x with a; auto.
+  setoid_replace a with x in F; auto; congruence.
+  Qed.
+
+  Lemma for_all_spec :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Proof.
+  unfold For_all; induction s; simpl; intros.
+  split; intros; auto. inv.
+  destruct (f a) as [ ]_eqn:F.
+  rewrite IHs; auto. firstorder. inv; auto.
+  setoid_replace x with a; auto.
+  split; intros H'. discriminate.
+  rewrite H' in F; auto.
+  Qed.
+
+  Lemma exists_spec :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Proof.
+  unfold Exists; induction s; simpl; intros.
+  firstorder. discriminate. inv.
+  destruct (f a) as [ ]_eqn:F.
+  firstorder.
+  rewrite IHs; auto.
+  firstorder.
+  inv.
+  setoid_replace a with x in F; auto; congruence.
+  exists x; auto.
+  Qed.
+
+  Lemma partition_inf1 :
+   forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s),
+   Inf x s -> Inf x (fst (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  intuition.
+  intros x l Hrec f a Hs Ha; inv.
+  generalize (Hrec f a H).
+  case (f x); case (partition f l); simpl.
+  auto.
+  intros; apply H2; apply Inf_lt with x; auto.
+  Qed.
+
+  Lemma partition_inf2 :
+   forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s),
+   Inf x s -> Inf x (snd (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  intuition.
+  intros x l Hrec f a Hs Ha; inv.
+  generalize (Hrec f a H).
+  case (f x); case (partition f l); simpl.
+  intros; apply H2; apply Inf_lt with x; auto.
+  auto.
+  Qed.
+
+  Global Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec f Hs; inv.
+  generalize (Hrec f H); generalize (@partition_inf1 l f x).
+  case (f x); case (partition f l); simpl; auto.
+  Qed.
+
+  Global Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec f Hs; inv.
+  generalize (Hrec f H); generalize (@partition_inf2 l f x).
+  case (f x); case (partition f l); simpl; auto.
+  Qed.
+
+  Lemma partition_spec1 :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>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_spec2 :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>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.
+
+  End ForNotations.
+
+  Definition In := InA X.eq.
+  Instance In_compat : Proper (X.eq==>eq==> iff) In.
+  Proof. repeat red; intros; rewrite H, H0; auto. Qed.
+
+(*
+  Module IN <: IN X.
+   Definition t := t.
+   Definition In := In.
+   Instance In_compat : Proper (X.eq==>eq==>iff) In.
+   Proof.
+   intros x x' Ex s s' Es. subst. rewrite Ex; intuition.
+   Qed.
+   Definition Equal := Equal.
+   Definition Empty := Empty.
+  End IN.
+  Include MakeSetOrdering X IN.
+
+  Lemma Ok_Above_Add : forall x s, Ok (x::s) -> Above x s /\ Add x s (x::s).
+  Proof.
+  intros.
+  inver Ok.
+  split.
+  intros y Hy. eapply Sort_Inf_In; eauto.
+  red. intuition. inver In; auto. rewrite <- H2; left; auto.
+  right; auto.
+  Qed.
+
+  Lemma compare_spec :
+   forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'), Cmp eq lt (compare s s') s s'.
+  Proof.
+  induction s as [|x s IH]; intros [|x' s'] Hs Hs'; simpl; intuition.
+  destruct (Ok_Above_Add Hs').
+  eapply lt_empty_l; eauto. intros y Hy. inver InA.
+  destruct (Ok_Above_Add Hs).
+  eapply lt_empty_l; eauto. intros y Hy. inver InA.
+  destruct (Ok_Above_Add Hs); destruct (Ok_Above_Add Hs').
+  inver Ok. unfold Ok in IH. specialize (IH s').
+  elim_compare x x'; intros.
+  destruct (compare s s'); unfold Cmp, flip in IH; auto.
+  intro y; split; intros; inver InA; try (left; order).
+  right; rewrite <- IH; auto.
+  right; rewrite IH; auto.
+  eapply (@lt_add_eq x x'); eauto.
+  eapply (@lt_add_eq x' x); eauto.
+  eapply (@lt_add_lt x x'); eauto.
+  eapply (@lt_add_lt x' x); eauto.
+  Qed.
+*)
+
+  Module L := MakeListOrdering X.
+  Definition eq := L.eq.
+  Definition eq_equiv := L.eq_equiv.
+  Definition lt l1 l2 :=
+    exists l1', exists l2', Ok l1' /\ Ok l2' /\
+      eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'.
+
+  Instance lt_strorder : StrictOrder lt.
+  Proof.
+  split.
+  intros s (s1 & s2 & B1 & B2 & E1 & E2 & L).
+  assert (eqlistA X.eq s1 s2).
+   apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *.
+   transitivity s; auto. symmetry; auto.
+  rewrite H in L.
+  apply (StrictOrder_Irreflexive s2); auto.
+  intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12)
+                  (s2'' & s3' & B2' & B3 & E2' & E3 & L23).
+  exists s1', s3'; do 4 (split; trivial).
+  assert (eqlistA X.eq s2' s2'').
+   apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *.
+   transitivity s2; auto. symmetry; auto.
+  transitivity s2'; auto.
+  rewrite H; auto.
+  Qed.
+
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+  Proof.
+  intros s1 s2 E12 s3 s4 E34. split.
+  intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
+  exists s1', s3'; do 2 (split; trivial).
+   split. transitivity s1; auto. symmetry; auto.
+   split; auto. transitivity s3; auto. symmetry; auto.
+  intros (s1' & s3' & B1 & B3 & E1 & E3 & LT).
+  exists s1', s3'; do 2 (split; trivial).
+   split. transitivity s2; auto.
+   split; auto. transitivity s4; auto.
+  Qed.
+
+  Lemma compare_spec_aux : forall s s', Cmp eq L.lt (compare s s') s s'.
+  Proof.
+  induction s as [|x s IH]; intros [|x' s']; simpl; intuition.
+  red; auto.
+  elim_compare x x'; intros; auto.
+  specialize (IH s').
+  destruct (compare s s'); unfold Cmp, flip, eq in IH; auto.
+  apply L.eq_cons; auto.
+  Qed.
+
+  Lemma compare_spec : forall s s', Ok s -> Ok s' ->
+   Cmp eq lt (compare s s') s s'.
+  Proof.
+  intros s s' Hs Hs'.
+  generalize (compare_spec_aux s s').
+  destruct (compare s s'); unfold Cmp, flip in *; auto.
+  exists s, s'; repeat split; auto using @ok.
+  exists s', s; repeat split; auto using @ok.
+  Qed.
+
+End MakeRaw.
+
+(** * 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 Raw := MakeRaw X.
+ Include Raw2Sets X Raw.
+End Make.
diff --git a/theories/MSets/MSetProperties.v b/theories/MSets/MSetProperties.v
new file mode 100644
index 000000000..24e889eee
--- /dev/null
+++ b/theories/MSets/MSetProperties.v
@@ -0,0 +1,1183 @@
+(***********************************************************************)
+(*  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$ *)
+
+(** * Finite sets library *)
+
+(** This functor derives additional properties from [MSetInterface.S].
+    Contrary to the functor in [MSetEqProperties] 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 MSetInterface.
+Require Import DecidableTypeEx MSetFacts MSetDecide.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Hint Unfold transpose.
+
+(** First, a functor for Weak Sets in functorial version. *)
+
+Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E).
+  Module Import Dec := WDecideOn E M.
+  Module Import FM := Dec.F (* MSetFacts.WFactsOn E M *).
+  Import M.
+
+  Lemma In_dec : forall x s, {In x s} + {~ In x s}.
+  Proof.
+  intros; generalize (mem_iff s x); case (mem x s); intuition.
+  Qed.
+
+  Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s.
+
+  Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s.
+  Proof.
+  unfold Add.
+  split; intros.
+  red; intros.
+  rewrite H; clear H.
+  fsetdec.
+  fsetdec.
+  Qed.
+
+  Ltac expAdd := repeat rewrite Add_Equal.
+
+  Section BasicProperties.
+
+  Variable s s' s'' s1 s2 s3 : t.
+  Variable x x' : elt.
+
+  Lemma equal_refl : s[=]s.
+  Proof. fsetdec. Qed.
+
+  Lemma equal_sym : s[=]s' -> s'[=]s.
+  Proof. fsetdec. Qed.
+
+  Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_refl : s[<=]s.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_equal : s[=]s' -> s[<=]s'.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_empty : empty[<=]s.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2.
+  Proof. fsetdec. Qed.
+
+  Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2.
+  Proof. fsetdec. Qed.
+
+  Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2.
+  Proof. fsetdec. Qed.
+
+  Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1.
+  Proof. intuition fsetdec. Qed.
+
+  Lemma empty_is_empty_1 : Empty s -> s[=]empty.
+  Proof. fsetdec. Qed.
+
+  Lemma empty_is_empty_2 : s[=]empty -> Empty s.
+  Proof. fsetdec. Qed.
+
+  Lemma add_equal : In x s -> add x s [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma add_add : add x (add x' s) [=] add x' (add x s).
+  Proof. fsetdec. Qed.
+
+  Lemma remove_equal : ~ In x s -> remove x s [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'.
+  Proof. fsetdec. Qed.
+
+  Lemma add_remove : In x s -> add x (remove x s) [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma remove_add : ~In x s -> remove x (add x s) [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma singleton_equal_add : singleton x [=] add x empty.
+  Proof. fsetdec. Qed.
+
+  Lemma remove_singleton_empty :
+   In x s -> remove x s [=] empty -> singleton x [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma union_sym : union s s' [=] union s' s.
+  Proof. fsetdec. Qed.
+
+  Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'.
+  Proof. fsetdec. Qed.
+
+  Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''.
+  Proof. fsetdec. Qed.
+
+  Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''.
+  Proof. fsetdec. Qed.
+
+  Lemma union_assoc : union (union s s') s'' [=] union s (union s' s'').
+  Proof. fsetdec. Qed.
+
+  Lemma add_union_singleton : add x s [=] union (singleton x) s.
+  Proof. fsetdec. Qed.
+
+  Lemma union_add : union (add x s) s' [=] add x (union s s').
+  Proof. fsetdec. Qed.
+
+  Lemma union_remove_add_1 :
+   union (remove x s) (add x s') [=] union (add x s) (remove x s').
+  Proof. fsetdec. Qed.
+
+  Lemma union_remove_add_2 : In x s ->
+   union (remove x s) (add x s') [=] union s s'.
+  Proof. fsetdec. Qed.
+
+  Lemma union_subset_1 : s [<=] union s s'.
+  Proof. fsetdec. Qed.
+
+  Lemma union_subset_2 : s' [<=] union s s'.
+  Proof. fsetdec. Qed.
+
+  Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''.
+  Proof. fsetdec. Qed.
+
+  Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''.
+  Proof. fsetdec. Qed.
+
+  Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'.
+  Proof. fsetdec. Qed.
+
+  Lemma empty_union_1 : Empty s -> union s s' [=] s'.
+  Proof. fsetdec. Qed.
+
+  Lemma empty_union_2 : Empty s -> union s' s [=] s'.
+  Proof. fsetdec. Qed.
+
+  Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s').
+  Proof. fsetdec. Qed.
+
+  Lemma inter_sym : inter s s' [=] inter s' s.
+  Proof. fsetdec. Qed.
+
+  Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''.
+  Proof. fsetdec. Qed.
+
+  Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''.
+  Proof. fsetdec. Qed.
+
+  Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s'').
+  Proof. fsetdec. Qed.
+
+  Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s'').
+  Proof. fsetdec. Qed.
+
+  Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s'').
+  Proof. fsetdec. Qed.
+
+  Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s').
+  Proof. fsetdec. Qed.
+
+  Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'.
+  Proof. fsetdec. Qed.
+
+  Lemma empty_inter_1 : Empty s -> Empty (inter s s').
+  Proof. fsetdec. Qed.
+
+  Lemma empty_inter_2 : Empty s' -> Empty (inter s s').
+  Proof. fsetdec. Qed.
+
+  Lemma inter_subset_1 : inter s s' [<=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma inter_subset_2 : inter s s' [<=] s'.
+  Proof. fsetdec. Qed.
+
+  Lemma inter_subset_3 :
+   s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'.
+  Proof. fsetdec. Qed.
+
+  Lemma empty_diff_1 : Empty s -> Empty (diff s s').
+  Proof. fsetdec. Qed.
+
+  Lemma empty_diff_2 : Empty s -> diff s' s [=] s'.
+  Proof. fsetdec. Qed.
+
+  Lemma diff_subset : diff s s' [<=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty.
+  Proof. fsetdec. Qed.
+
+  Lemma remove_diff_singleton :
+   remove x s [=] diff s (singleton x).
+  Proof. fsetdec. Qed.
+
+  Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty.
+  Proof. fsetdec. Qed.
+
+  Lemma diff_inter_all : union (diff s s') (inter s s') [=] s.
+  Proof. fsetdec. Qed.
+
+  Lemma Add_add : Add x s (add x s).
+  Proof. expAdd; fsetdec. Qed.
+
+  Lemma Add_remove : In x s -> Add x (remove x s) s.
+  Proof. expAdd; fsetdec. Qed.
+
+  Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s'').
+  Proof. expAdd; fsetdec. Qed.
+
+  Lemma inter_Add :
+   In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s'').
+  Proof. expAdd; fsetdec. Qed.
+
+  Lemma union_Equal :
+   In x s'' -> Add x s s' -> union s s'' [=] union s' s''.
+  Proof. expAdd; fsetdec. Qed.
+
+  Lemma inter_Add_2 :
+   ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''.
+  Proof. expAdd; fsetdec. Qed.
+
+  End BasicProperties.
+
+  Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set.
+  Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym
+    subset_trans subset_empty subset_remove_3 subset_diff subset_add_3
+    subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal
+    remove_equal singleton_equal_add union_subset_equal union_equal_1
+    union_equal_2 union_assoc add_union_singleton union_add union_subset_1
+    union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2
+    inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2
+    empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1
+    empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union
+    inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal
+    remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove
+    Equal_remove add_add : set.
+
+  (** * Properties of elements *)
+
+  Lemma elements_Empty : forall s, Empty s <-> elements s = nil.
+  Proof.
+  intros.
+  unfold Empty.
+  split; intros.
+  assert (forall a, ~ List.In a (elements s)).
+   red; intros.
+   apply (H a).
+   rewrite elements_iff.
+   rewrite InA_alt; exists a; auto.
+  destruct (elements s); auto.
+  elim (H0 e); simpl; auto.
+  red; intros.
+  rewrite elements_iff in H0.
+  rewrite InA_alt in H0; destruct H0.
+  rewrite H in H0; destruct H0 as (_,H0); inversion H0.
+  Qed.
+
+  Lemma elements_empty : elements empty = nil.
+  Proof.
+  rewrite <-elements_Empty; auto with set.
+  Qed.
+
+  (** * Conversions between lists and sets *)
+
+  Definition of_list (l : list elt) := List.fold_right add empty l.
+
+  Definition to_list := elements.
+
+  Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l.
+  Proof.
+  induction l; simpl; intro x.
+  rewrite empty_iff, InA_nil. intuition.
+  rewrite add_iff, InA_cons, IHl. intuition.
+  Qed.
+
+  Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l.
+  Proof.
+  unfold to_list; red; intros.
+  rewrite <- elements_iff; apply of_list_1.
+  Qed.
+
+  Lemma of_list_3 : forall s, of_list (to_list s) [=] s.
+  Proof.
+  unfold to_list; red; intros.
+  rewrite of_list_1; symmetry; apply elements_iff.
+  Qed.
+
+  (** * Fold *)
+
+  Section Fold.
+
+  Notation NoDup := (NoDupA E.eq).
+  Notation InA := (InA E.eq).
+
+  (** ** Induction principles for fold (contributed by S. Lescuyer) *)
+
+  (** In the following lemma, the step hypothesis is deliberately restricted
+      to the precise set s we are considering. *)
+
+  Theorem fold_rec :
+    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t),
+     (forall s', Empty s' -> P s' i) ->
+     (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' ->
+       P s' a -> P s'' (f x a)) ->
+     P s (fold f s i).
+  Proof.
+  intros A P f i s Pempty Pstep.
+  rewrite fold_1; unfold flip; rewrite <- fold_left_rev_right.
+  set (l:=rev (elements s)).
+  assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' ->
+           P s' a -> P s'' (f x a)).
+   intros; eapply Pstep; eauto.
+   rewrite elements_iff, <- InA_rev; auto with *.
+  assert (Hdup : NoDup l) by
+    (unfold l; eauto using elements_3w, NoDupA_rev with *).
+  assert (Hsame : forall x, In x s <-> InA x l) by
+    (unfold l; intros; rewrite elements_iff, InA_rev; intuition).
+  clear Pstep; clearbody l; revert s Hsame; induction l.
+  (* empty *)
+  intros s Hsame; simpl.
+  apply Pempty. intro x. rewrite Hsame, InA_nil; intuition.
+  (* step *)
+  intros s Hsame; simpl.
+  apply Pstep' with (of_list l); auto.
+   inversion_clear Hdup; rewrite of_list_1; auto.
+   red. intros. rewrite Hsame, of_list_1, InA_cons; intuition.
+  apply IHl.
+   intros; eapply Pstep'; eauto.
+   inversion_clear Hdup; auto.
+   exact (of_list_1 l).
+  Qed.
+
+  (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this
+      case, [P] must be compatible with equality of sets *)
+
+  Theorem fold_rec_bis :
+    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t),
+     (forall s s' a, s[=]s' -> P s a -> P s' a) ->
+     (P empty i) ->
+     (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) ->
+     P s (fold f s i).
+  Proof.
+  intros A P f i s Pmorphism Pempty Pstep.
+  apply fold_rec; intros.
+  apply Pmorphism with empty; auto with set.
+  rewrite Add_Equal in H1; auto with set.
+  apply Pmorphism with (add x s'); auto with set.
+  Qed.
+
+  Lemma fold_rec_nodep :
+    forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t),
+     P i -> (forall x a, In x s -> P a -> P (f x a)) ->
+     P (fold f s i).
+  Proof.
+  intros; apply fold_rec_bis with (P:=fun _ => P); auto.
+  Qed.
+
+  (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] :
+      the step hypothesis must here be applicable to any [x].
+      At the same time, it looks more like an induction principle,
+      and hence can be easier to use. *)
+
+  Lemma fold_rec_weak :
+    forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A),
+    (forall s s' a, s[=]s' -> P s a -> P s' a) ->
+    P empty i ->
+    (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) ->
+    forall s, P s (fold f s i).
+  Proof.
+  intros; apply fold_rec_bis; auto.
+  Qed.
+
+  Lemma fold_rel :
+    forall (A B:Type)(R : A -> B -> Type)
+     (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t),
+     R i j ->
+     (forall x a b, In x s -> R a b -> R (f x a) (g x b)) ->
+     R (fold f s i) (fold g s j).
+  Proof.
+  intros A B R f g i j s Rempty Rstep.
+  do 2 (rewrite fold_1; unfold flip; rewrite <- fold_left_rev_right).
+  set (l:=rev (elements s)).
+  assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by
+    (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with *).
+  clearbody l; clear Rstep s.
+  induction l; simpl; auto.
+  Qed.
+
+  (** From the induction principle on [fold], we can deduce some general
+      induction principles on sets. *)
+
+  Lemma set_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 s, P s.
+  Proof.
+  intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto.
+  Qed.
+
+  Lemma set_induction_bis :
+   forall P : t -> Type,
+   (forall s s', s [=] s' -> P s -> P s') ->
+   P empty ->
+   (forall x s, ~In x s -> P s -> P (add x s)) ->
+   forall s, P s.
+  Proof.
+  intros.
+  apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto.
+  Qed.
+
+  (** [fold] can be used to reconstruct the same initial set. *)
+
+  Lemma fold_identity : forall s, fold add s empty [=] s.
+  Proof.
+  intros.
+  apply fold_rec with (P:=fun s acc => acc[=]s); auto with set.
+  intros. rewrite H2; rewrite Add_Equal in H1; auto with set.
+  Qed.
+
+  (** ** Alternative (weaker) specifications for [fold] *)
+
+  (** When [MSets] 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 : Type) (i : A) (f : elt -> A -> A),
+      exists l : list elt,
+        NoDup l /\
+        (forall x : elt, In x s <-> InA x l) /\
+        fold f s i = fold_right f i l.
+  Proof.
+  intros; exists (rev (elements s)); split.
+  apply NoDupA_rev; auto with *.
+  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 : Type) (eqA : A -> A -> Prop)
+     (st : Equivalence 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.
+  reflexivity.
+  elim (H e).
+  elim (H2 e); intuition.
+  Qed.
+
+  Lemma fold_2 :
+   forall s s' x (A : Type) (eqA : A -> A -> Prop)
+     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
+   Proper (E.eq==>eqA==>eqA) f ->
+   transpose eqA f ->
+   ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
+  Proof.
+  intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2)));
+    destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))).
+  rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2.
+  apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto.
+  eauto with *.
+  rewrite <- Hl1; auto.
+  intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1;
+   rewrite (H2 a); intuition.
+  Qed.
+
+  (** In fact, [fold] on empty sets is more than equivalent to
+      the initial element, it is Leibniz-equal to it. *)
+
+  Lemma fold_1b :
+   forall s (A : Type)(i : A) (f : elt -> A -> A),
+   Empty s -> (fold f s i) = i.
+  Proof.
+  intros.
+  rewrite FM.fold_1.
+  rewrite elements_Empty in H; rewrite H; simpl; auto.
+  Qed.
+
+  Section Fold_More.
+
+  Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
+  Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f).
+
+  Lemma fold_commutes : forall i s x,
+   eqA (fold f s (f x i)) (f x (fold f s i)).
+  Proof.
+  intros.
+  apply fold_rel with (R:=fun u v => eqA u (f x v)); intros.
+  reflexivity.
+  transitivity (f x0 (f x b)); auto.
+  apply Comp; auto.
+  Qed.
+
+  (** ** Fold is a morphism *)
+
+  Lemma fold_init : forall i i' s, eqA i i' ->
+   eqA (fold f s i) (fold f s i').
+  Proof.
+  intros. apply fold_rel with (R:=eqA); auto.
+  intros; apply Comp; auto.
+  Qed.
+
+  Lemma fold_equal :
+   forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
+  Proof.
+  intros i s; pattern s; apply set_induction; clear s; intros.
+  transitivity i.
+  apply fold_1; auto.
+  symmetry; apply fold_1; auto.
+  rewrite <- H0; auto.
+  transitivity (f x (fold f s i)).
+  apply fold_2 with (eqA := eqA); auto.
+  symmetry; apply fold_2 with (eqA := eqA); auto.
+  unfold Add in *; intros.
+  rewrite <- H2; auto.
+  Qed.
+
+  (** ** Fold and other set operators *)
+
+  Lemma fold_empty : forall i, fold f empty i = i.
+  Proof.
+  intros i; apply fold_1b; auto with set.
+  Qed.
+
+  Lemma fold_add : forall i 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 with set.
+  Qed.
+
+  Lemma add_fold : forall i s x, In x s ->
+   eqA (fold f (add x s) i) (fold f s i).
+  Proof.
+  intros; apply fold_equal; auto with set.
+  Qed.
+
+  Lemma remove_fold_1: forall i s x, In x s ->
+   eqA (f x (fold f (remove x s) i)) (fold f s i).
+  Proof.
+  intros.
+  symmetry.
+  apply fold_2 with (eqA:=eqA); auto with set.
+  Qed.
+
+  Lemma remove_fold_2: forall i s x, ~In x s ->
+   eqA (fold f (remove x s) i) (fold f s i).
+  Proof.
+  intros.
+  apply fold_equal; auto with set.
+  Qed.
+
+  Lemma fold_union_inter : forall i 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.
+  transitivity (fold f s' (fold f (inter s s') i)).
+  apply fold_equal; auto with set.
+  transitivity (fold f s' i).
+  apply fold_init; auto.
+  apply fold_1; auto with set.
+  symmetry; apply fold_1; auto.
+  rename s'0 into s''.
+  destruct (In_dec x s').
+  (* In x s' *)
+  transitivity (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.
+  transitivity (f x (fold f s (fold f s' i))).
+  transitivity (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.
+  transitivity (f x (fold f (union s s') (fold f (inter s s') i))).
+  apply fold_commutes; auto.
+  apply Comp; auto.
+  symmetry; apply fold_2 with (eqA:=eqA); auto.
+  (* ~(In x s') *)
+  transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))).
+  apply fold_2 with (eqA:=eqA); auto with set.
+  transitivity (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.
+  transitivity (f x (fold f s (fold f s' i))).
+  apply Comp; auto.
+  symmetry; apply fold_2 with (eqA:=eqA); auto.
+  Qed.
+
+  Lemma fold_diff_inter : forall i s s',
+   eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i).
+  Proof.
+  intros.
+  transitivity (fold f (union (diff s s') (inter s s'))
+               (fold f (inter (diff s s') (inter s s')) i)).
+  symmetry; apply fold_union_inter; auto.
+  transitivity (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 i 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.
+  transitivity (fold f (union s s') (fold f (inter s s') i)).
+  apply fold_init; auto.
+  symmetry; apply fold_1; auto with set.
+  unfold Empty; intro a; generalize (H a); set_iff; tauto.
+  apply fold_union_inter; auto.
+  Qed.
+
+  End Fold_More.
+
+  Lemma fold_plus :
+   forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p.
+  Proof.
+  intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto.
+  Qed.
+
+  End Fold.
+
+  (** * Cardinal *)
+
+  (** ** Characterization of cardinal in terms of fold *)
+
+  Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0.
+  Proof.
+  intros; rewrite cardinal_1; rewrite FM.fold_1.
+  symmetry; apply fold_left_length; auto.
+  Qed.
+
+  (** ** Old specifications for [cardinal]. *)
+
+  Lemma cardinal_0 :
+     forall s, exists l : list elt,
+        NoDupA E.eq l /\
+        (forall x : elt, In x s <-> InA E.eq x l) /\
+        cardinal s = length l.
+  Proof.
+  intros; exists (elements s); intuition; apply cardinal_1.
+  Qed.
+
+  Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0.
+  Proof.
+  intros; rewrite cardinal_fold; apply fold_1; auto with *.
+  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.
+  split; congruence.
+  congruence.
+  Qed.
+
+  (** ** Cardinal and (non-)emptiness *)
+
+  Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0.
+  Proof.
+  intros.
+  rewrite elements_Empty, FM.cardinal_1.
+  destruct (elements s); intuition; discriminate.
+  Qed.
+
+  Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s.
+  Proof.
+  intros; rewrite cardinal_Empty; auto.
+  Qed.
+  Hint Resolve cardinal_inv_1.
+
+  Lemma cardinal_inv_2 :
+   forall s n, cardinal s = S n -> { x : elt | In x s }.
+  Proof.
+  intros; rewrite FM.cardinal_1 in H.
+  generalize (elements_2 (s:=s)).
+  destruct (elements s); try discriminate.
+  exists e; auto.
+  Qed.
+
+  Lemma cardinal_inv_2b :
+   forall s, cardinal s <> 0 -> { x : elt | In x s }.
+  Proof.
+  intro; generalize (@cardinal_inv_2 s); destruct cardinal;
+   [intuition|eauto].
+  Qed.
+
+  (** ** Cardinal is a morphism *)
+
+  Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'.
+  Proof.
+  symmetry.
+  remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H.
+  induction n; intros.
+  apply cardinal_1; rewrite <- H; auto.
+  destruct (cardinal_inv_2 Heqn) as (x,H2).
+  revert Heqn.
+  rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set.
+  rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set.
+  Qed.
+
+  Add Morphism cardinal : cardinal_m.
+  Proof.
+  exact Equal_cardinal.
+  Qed.
+
+  Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal.
+
+  (** ** Cardinal and set operators *)
+
+  Lemma empty_cardinal : cardinal empty = 0.
+  Proof.
+  rewrite cardinal_fold; apply fold_1; auto with *.
+  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:=@Logic.eq nat); auto with *.
+  congruence.
+  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.
+  split; congruence.
+  congruence.
+  Qed.
+
+  Lemma subset_cardinal :
+   forall s s', s[<=]s' -> cardinal s <= cardinal s' .
+  Proof.
+  intros.
+  rewrite <- (diff_inter_cardinal s' s).
+  rewrite (inter_sym s' s).
+  rewrite (inter_subset_equal H); auto with arith.
+  Qed.
+
+  Lemma subset_cardinal_lt :
+   forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'.
+  Proof.
+  intros.
+  rewrite <- (diff_inter_cardinal s' s).
+  rewrite (inter_sym s' s).
+  rewrite (inter_subset_equal H).
+  generalize (@cardinal_inv_1 (diff s' s)).
+  destruct (cardinal (diff s' s)).
+  intro H2; destruct (H2 (refl_equal _) x).
+  set_iff; auto.
+  intros _.
+  change (0 + cardinal s < S n + cardinal s).
+  apply Plus.plus_lt_le_compat; auto with arith.
+  Qed.
+
+  Theorem union_inter_cardinal :
+   forall s s', cardinal (union s s') + cardinal (inter s s')  = cardinal s  + cardinal s' .
+  Proof.
+  intros.
+  do 4 rewrite cardinal_fold.
+  do 2 rewrite <- fold_plus.
+  apply fold_union_inter with (eqA:=@Logic.eq nat); auto with *.
+  congruence.
+  Qed.
+
+  Lemma union_cardinal_inter :
+   forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s').
+  Proof.
+  intros.
+  rewrite <- union_inter_cardinal.
+  rewrite Plus.plus_comm.
+  auto with arith.
+  Qed.
+
+  Lemma union_cardinal_le :
+   forall s s', cardinal (union s s') <= cardinal s  + cardinal s'.
+  Proof.
+   intros; generalize (union_inter_cardinal s s').
+   intros; rewrite <- H; auto with arith.
+  Qed.
+
+  Lemma add_cardinal_1 :
+   forall s x, In x s -> cardinal (add x s) = cardinal s.
+  Proof.
+  auto with set.
+  Qed.
+
+  Lemma add_cardinal_2 :
+   forall s x, ~In x s -> cardinal (add x s) = S (cardinal s).
+  Proof.
+  intros.
+  do 2 rewrite cardinal_fold.
+  change S with ((fun _ => S) x);
+   apply fold_add with (eqA:=@Logic.eq nat); auto with *.
+  congruence.
+  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:=@Logic.eq nat); auto with *.
+  congruence.
+  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 WPropertiesOn.
+
+(** Now comes variants for self-contained weak sets and for full sets.
+    For these variants, only one argument is necessary. Thanks to
+    the subtyping [WS<=S], the [Properties] functor which is meant to be
+    used on modules [(M:S)] can simply be an alias of [WProperties]. *)
+
+Module WProperties (M:WSets) := WPropertiesOn M.E M.
+Module Properties := WProperties.
+
+
+(** Now comes some properties specific to the element ordering,
+    invalid for Weak Sets. *)
+
+Module OrdProperties (M:Sets).
+  Module ME:=OrderedTypeFacts(M.E).
+  Module Import P := Properties M.
+  Import FM.
+  Import M.E.
+  Import M.
+
+  Hint Resolve elements_spec2.
+  Hint Immediate
+    min_elt_spec1 min_elt_spec2 min_elt_spec3
+    max_elt_spec1 max_elt_spec2 max_elt_spec3 : set.
+
+  (** First, a specialized version of SortA_equivlistA_eqlistA: *)
+  Lemma sort_equivlistA_eqlistA : forall l l' : list elt,
+   sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'.
+  Proof.
+  apply SortA_equivlistA_eqlistA; eauto with *.
+  Qed.
+
+  Definition gtb x y := match E.compare x y with Gt => true | _ => false end.
+  Definition leb x := fun y => negb (gtb x y).
+
+  Definition elements_lt x s := List.filter (gtb x) (elements s).
+  Definition elements_ge x s := List.filter (leb x) (elements s).
+
+  Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x.
+  Proof.
+   intros; unfold gtb; ME.elim_compare x y; intuition; try discriminate; ME.order.
+  Qed.
+
+  Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x.
+  Proof.
+   intros; unfold leb, gtb; ME.elim_compare x y; intuition; try discriminate; ME.order.
+  Qed.
+
+  Lemma gtb_compat : forall x, Proper (E.eq==>Logic.eq) (gtb x).
+  Proof.
+   red; intros x a b H.
+   generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto.
+   intros.
+   symmetry; rewrite H1.
+   apply ME.eq_lt with a; auto.
+   rewrite <- H0; auto.
+   intros.
+   rewrite H0.
+   apply ME.eq_lt with b; auto.
+   rewrite <- H1; auto.
+  Qed.
+
+  Lemma leb_compat : forall x, Proper (E.eq==>Logic.eq) (leb x).
+  Proof.
+   red; intros x a b H; unfold leb.
+   f_equal; apply gtb_compat; auto.
+  Qed.
+  Hint Resolve gtb_compat leb_compat.
+
+  Lemma elements_split : forall x s,
+   elements s = elements_lt x s ++ elements_ge x s.
+  Proof.
+  unfold elements_lt, elements_ge, leb; intros.
+  eapply (@filter_split _ E.eq); eauto with *.
+  intros.
+  rewrite gtb_1 in H.
+  assert (~E.lt y x).
+   unfold gtb in *; ME.elim_compare x y; intuition;
+   try discriminate; ME.order.
+  ME.order.
+  Qed.
+
+  Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' ->
+    eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s).
+  Proof.
+  intros; unfold elements_ge, elements_lt.
+  apply sort_equivlistA_eqlistA; auto with set.
+  apply (@SortA_app _ E.eq); auto with *.
+  apply (@filter_sort _ E.eq); auto with *; eauto with *.
+  constructor; auto.
+  apply (@filter_sort _ E.eq); auto with *; eauto with *.
+  rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with *).
+  intros.
+  rewrite filter_InA in H1; auto with *; destruct H1.
+  rewrite leb_1 in H2.
+  rewrite <- elements_iff in H1.
+  assert (~E.eq x y).
+   contradict H; rewrite H; auto.
+  ME.order.
+  intros.
+  rewrite filter_InA in H1; auto with *; destruct H1.
+  rewrite gtb_1 in H3.
+  inversion_clear H2.
+  ME.order.
+  rewrite filter_InA in H4; auto with *; destruct H4.
+  rewrite leb_1 in H4.
+  ME.order.
+  red; intros a.
+  rewrite InA_app_iff, InA_cons, !filter_InA, <-!elements_iff,
+   leb_1, gtb_1, (H0 a) by (auto with *).
+  intuition.
+  ME.elim_compare a x; intuition.
+  right; right; split; auto.
+  ME.order.
+  Qed.
+
+  Definition Above x s := forall y, In y s -> E.lt y x.
+  Definition Below x s := forall y, In y s -> E.lt x y.
+
+  Lemma elements_Add_Above : forall s s' x,
+   Above x s -> Add x s s' ->
+     eqlistA E.eq (elements s') (elements s ++ x::nil).
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with set.
+  apply (@SortA_app _ E.eq); auto with *.
+  intros.
+  inversion_clear H2.
+  rewrite <- elements_iff in H1.
+  apply ME.lt_eq with x; auto.
+  inversion H3.
+  red; intros a.
+  rewrite InA_app_iff, InA_cons, InA_nil, <-!elements_iff, (H0 a)
+   by (auto with *).
+  intuition.
+  Qed.
+
+  Lemma elements_Add_Below : forall s s' x,
+   Below x s -> Add x s s' ->
+     eqlistA E.eq (elements s') (x::elements s).
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with set.
+  change (sort E.lt ((x::nil) ++ elements s)).
+  apply (@SortA_app _ E.eq); auto with *.
+  intros.
+  inversion_clear H1.
+  rewrite <- elements_iff in H2.
+  apply ME.eq_lt with x; auto.
+  inversion H3.
+  red; intros a.
+  rewrite InA_cons, <- !elements_iff, (H0 a); intuition.
+  Qed.
+
+  (** Two other induction principles on sets: we can be more restrictive
+      on the element we add at each step.  *)
+
+  Lemma set_induction_max :
+   forall P : t -> Type,
+   (forall s : t, Empty s -> P s) ->
+   (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') ->
+   forall s : t, P s.
+  Proof.
+  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
+  case_eq (max_elt s); intros.
+  apply X0 with (remove e s) e; auto with set.
+  apply IHn.
+  assert (S n = S (cardinal (remove e s))).
+   rewrite Heqn; apply cardinal_2 with e; auto with set.
+  inversion H0; auto.
+  red; intros.
+  rewrite remove_iff in H0; destruct H0.
+  generalize (@max_elt_spec2 s e y H H0); ME.order.
+
+  assert (H0:=max_elt_spec3 H).
+  rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn.
+  Qed.
+
+  Lemma set_induction_min :
+   forall P : t -> Type,
+   (forall s : t, Empty s -> P s) ->
+   (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') ->
+   forall s : t, P s.
+  Proof.
+  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto.
+  case_eq (min_elt s); intros.
+  apply X0 with (remove e s) e; auto with set.
+  apply IHn.
+  assert (S n = S (cardinal (remove e s))).
+   rewrite Heqn; apply cardinal_2 with e; auto with set.
+  inversion H0; auto.
+  red; intros.
+  rewrite remove_iff in H0; destruct H0.
+  generalize (@min_elt_spec2 s e y H H0); ME.order.
+
+  assert (H0:=min_elt_spec3 H).
+  rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn.
+  Qed.
+
+  (** More properties of [fold] : behavior with respect to Above/Below *)
+
+  Lemma fold_3 :
+   forall s s' x (A : Type) (eqA : A -> A -> Prop)
+     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
+   Proper (E.eq==>eqA==>eqA) f ->
+   Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
+  Proof.
+  intros.
+  rewrite !FM.fold_1.
+  unfold flip; rewrite <-!fold_left_rev_right.
+  change (f x (fold_right f i (rev (elements s)))) with
+    (fold_right f i (rev (x::nil)++rev (elements s))).
+  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto with *.
+  rewrite <- distr_rev.
+  apply eqlistA_rev.
+  apply elements_Add_Above; auto.
+  Qed.
+
+  Lemma fold_4 :
+   forall s s' x (A : Type) (eqA : A -> A -> Prop)
+     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
+   Proper (E.eq==>eqA==>eqA) f ->
+   Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)).
+  Proof.
+  intros.
+  rewrite !FM.fold_1.
+  change (eqA (fold_left (flip f) (elements s') i)
+              (fold_left (flip f) (x::elements s) i)).
+  unfold flip; rewrite <-!fold_left_rev_right.
+  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
+  apply eqlistA_rev.
+  apply elements_Add_Below; auto.
+  Qed.
+
+  (** The following results have already been proved earlier,
+    but we can now prove them with one hypothesis less:
+    no need for [(transpose eqA f)]. *)
+
+  Section FoldOpt.
+  Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
+  Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f).
+
+  Lemma fold_equal :
+   forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
+  Proof.
+  intros.
+  rewrite !FM.fold_1.
+  unfold flip; rewrite <- !fold_left_rev_right.
+  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
+  apply eqlistA_rev.
+  apply sort_equivlistA_eqlistA; auto with set.
+  red; intro a; do 2 rewrite <- elements_iff; auto.
+  Qed.
+
+  Lemma add_fold : forall i s x, In x s ->
+   eqA (fold f (add x s) i) (fold f s i).
+  Proof.
+  intros; apply fold_equal; auto with set.
+  Qed.
+
+  Lemma remove_fold_2: forall i s x, ~In x s ->
+   eqA (fold f (remove x s) i) (fold f s i).
+  Proof.
+  intros.
+  apply fold_equal; auto with set.
+  Qed.
+
+  End FoldOpt.
+
+  (** An alternative version of [choose_3] *)
+
+  Lemma choose_equal : forall s s', Equal s s' ->
+    match choose s, choose s' with
+      | Some x, Some x' => E.eq x x'
+      | None, None => True
+      | _, _ => False
+     end.
+  Proof.
+  intros s s' H;
+  generalize (@choose_spec1 s)(@choose_spec2 s)
+             (@choose_spec1 s')(@choose_spec2 s')(@choose_spec3 s s');
+  destruct (choose s); destruct (choose s'); simpl; intuition.
+  apply H5 with e; rewrite <-H; auto.
+  apply H5 with e; rewrite H; auto.
+  Qed.
+
+End OrdProperties.
diff --git a/theories/MSets/MSetToFiniteSet.v b/theories/MSets/MSetToFiniteSet.v
new file mode 100644
index 000000000..e8f8ab5e9
--- /dev/null
+++ b/theories/MSets/MSetToFiniteSet.v
@@ -0,0 +1,158 @@
+(***********************************************************************)
+(*  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$ *)
+
+(** * Finite sets library : conversion to old [Finite_sets] *)
+
+Require Import Ensembles Finite_sets.
+Require Import MSetInterface MSetProperties OrderedType2Ex DecidableType2Ex.
+
+(** * Going from [MSets] with usual Leibniz equality
+    to the good old [Ensembles] and [Finite_sets] theory. *)
+
+Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U).
+ Module MP:= WProperties_fun U M.
+ Import M MP FM Ensembles Finite_sets.
+
+ Definition mkEns : M.t -> Ensemble M.elt :=
+   fun s x => M.In x s.
+
+ Notation " !! " := mkEns.
+
+ Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x.
+ Proof.
+ unfold In; compute; auto with extcore.
+ Qed.
+
+ Lemma Subset_Included : forall s s',  s[<=]s'  <-> Included _ (!!s) (!!s').
+ Proof.
+ unfold Subset, Included, In, mkEns; intuition.
+ Qed.
+
+ Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity).
+
+ Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'.
+ Proof.
+ intros.
+ rewrite double_inclusion.
+ unfold Subset, Included, Same_set, In, mkEns; intuition.
+ Qed.
+
+ Lemma empty_Empty_Set : !!M.empty === Empty_set _.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1.
+ Qed.
+
+ Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intros.
+ destruct(H x H0).
+ inversion H0.
+ Qed.
+
+ Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x .
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; try constructor; auto.
+ Qed.
+
+ Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s').
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto.
+ Qed.
+
+ Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s').
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; try constructor; auto.
+ Qed.
+
+ Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; auto with sets.
+ inversion H0.
+ constructor 2; constructor.
+ constructor 1; auto.
+ Qed.
+
+ Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intros.
+ red in H; rewrite H in H0.
+ destruct H0.
+ inversion H0.
+ constructor 2; constructor.
+ constructor 1; auto.
+ red in H; rewrite H.
+ inversion H0; auto.
+ inversion H1; auto.
+ Qed.
+
+ Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x.
+ Proof.
+ unfold Same_set, Included, mkEns, In.
+ split; intro; set_iff; inversion 1; auto with sets.
+ split; auto.
+ contradict H1.
+ inversion H1; auto.
+ Qed.
+
+ Lemma mkEns_Finite : forall s, Finite _ (!!s).
+ Proof.
+ intro s; pattern s; apply set_induction; clear s; intros.
+ intros; replace (!!s) with (Empty_set elt); auto with sets.
+ symmetry; apply Extensionality_Ensembles.
+ apply Empty_Empty_set; auto.
+ replace (!!s') with (Add _ (!!s) x).
+ constructor 2; auto.
+ symmetry; apply Extensionality_Ensembles.
+ apply Add_Add; auto.
+ Qed.
+
+ Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s).
+ Proof.
+ intro s; pattern s; apply set_induction; clear s; intros.
+ intros; replace (!!s) with (Empty_set elt); auto with sets.
+ rewrite cardinal_1; auto with sets.
+ symmetry; apply Extensionality_Ensembles.
+ apply Empty_Empty_set; auto.
+ replace (!!s') with (Add _ (!!s) x).
+ rewrite (cardinal_2 H0 H1); auto with sets.
+ symmetry; apply Extensionality_Ensembles.
+ apply Add_Add; auto.
+ Qed.
+
+ (** we can even build a function from Finite Ensemble to MSet
+     ... at least in Prop. *)
+
+ Lemma Ens_to_MSet : forall e : Ensemble M.elt, Finite _ e ->
+   exists s:M.t, !!s === e.
+ Proof.
+ induction 1.
+ exists M.empty.
+ apply empty_Empty_Set.
+ destruct IHFinite as (s,Hs).
+ exists (M.add x s).
+ apply Extensionality_Ensembles in Hs.
+ rewrite <- Hs.
+ apply add_Add.
+ Qed.
+
+End WS_to_Finite_set.
+
+
+Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U) :=
+  WS_to_Finite_set U M.
+
+
diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v
new file mode 100644
index 000000000..d5a85e6c2
--- /dev/null
+++ b/theories/MSets/MSetWeakList.v
@@ -0,0 +1,528 @@
+(***********************************************************************)
+(*  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$ *)
+
+(** * Finite sets library *)
+
+(** This file proposes an implementation of the non-dependant
+    interface [MSetWeakInterface.S] using lists without redundancy. *)
+
+Require Import MSetInterface.
+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. *)
+
+
+(** ** The set operations. *)
+
+Module Ops (X: DecidableType) <: WOps 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.
+
+  Fixpoint mem (x : elt) (s : t) : 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) : 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) : t :=
+    match s with
+    | nil => nil
+    | y :: l =>
+        if X.eq_dec x y then l else y :: remove x l
+    end.
+
+  Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B :=
+    fold_left (flip f) s i.
+
+  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) : 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) : 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) : 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) : 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.
+
+End Ops.
+
+(** ** Proofs of set operation specifications. *)
+
+Module MakeRaw (X:DecidableType) <: WRawSets X.
+  Include Ops X.
+
+  Section ForNotations.
+  Notation NoDup := (NoDupA X.eq).
+  Notation In := (InA X.eq).
+
+  Definition IsOk := NoDup.
+
+  Class Ok (s:t) : Prop := { ok : NoDup s }.
+
+  Hint Constructors Ok.
+  Hint Resolve @ok.
+
+  Instance NoDup_Ok `(nd : NoDup s) : Ok s := nd.
+
+  Ltac inv_ok := match goal with
+   | H:Ok (_ :: _) |- _ => apply @ok in H; inversion_clear H; inv_ok
+   | H:Ok nil |- _ => clear H; inv_ok
+   | H:NoDup ?l |- _ => generalize (Build_Ok H); clear H; intro H; inv_ok
+   | _ => idtac
+  end.
+
+  Ltac inv := invlist InA; inv_ok.
+  Ltac constructors := repeat constructor.
+
+  Fixpoint isok l := match l with
+   | nil => true
+   | a::l => negb (mem a l) && isok l
+  end.
+
+  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_compat : Proper (X.eq==>eq==>iff) In.
+  Proof.
+  repeat red; intros. subst. rewrite H; auto.
+  Qed.
+
+  Lemma mem_spec : forall s x `{Ok s},
+   mem x s = true <-> In x s.
+  Proof.
+  induction s; intros.
+  split; intros; inv. discriminate.
+  simpl; destruct (X.eq_dec x a); split; intros; inv; auto.
+  right; rewrite <- IHs; auto.
+  rewrite IHs; auto.
+  Qed.
+
+  Lemma isok_iff : forall l, Ok l <-> isok l = true.
+  Proof.
+  induction l.
+  intuition.
+  simpl.
+  rewrite andb_true_iff.
+  rewrite negb_true_iff.
+  rewrite <- IHl.
+  split; intros H. inv.
+  split; auto.
+  apply not_true_is_false. rewrite mem_spec; auto.
+  destruct H; constructors; auto.
+  rewrite <- mem_spec; auto; congruence.
+  Qed.
+
+  Global Instance isok_Ok `(isok l = true) : Ok l | 10.
+  Proof.
+  intros. apply <- isok_iff; auto.
+  Qed.
+
+  Lemma add_spec :
+   forall (s : t) (x y : elt) {Hs : Ok s},
+     In y (add x s) <-> X.eq y x \/ In y s.
+  Proof.
+  induction s; simpl; intros.
+  intuition; inv; auto.
+  destruct X.eq_dec; inv; rewrite InA_cons, ?IHs; intuition.
+  left; eauto.
+  inv; auto.
+  Qed.
+
+  Global Instance add_ok s x `(Ok s) : Ok (add x s).
+  Proof.
+  induction s.
+  simpl; intuition.
+  intros; inv. simpl.
+  destruct X.eq_dec; auto.
+  constructors; auto.
+  intro; inv; auto.
+  rewrite add_spec in *; intuition.
+  Qed.
+
+  Lemma remove_spec :
+   forall (s : t) (x y : elt) {Hs : Ok s},
+     In y (remove x s) <-> In y s /\ ~X.eq y x.
+  Proof.
+  induction s; simpl; intros.
+  intuition; inv; auto.
+  destruct X.eq_dec; inv; rewrite !InA_cons, ?IHs; intuition.
+  elim H. setoid_replace a with y; eauto.
+  elim H3. setoid_replace x with y; eauto.
+  elim n. eauto.
+  Qed.
+
+  Global Instance remove_ok s x `(Ok s) : Ok (remove x s).
+  Proof.
+  induction s; simpl; intros.
+  auto.
+  destruct X.eq_dec; inv; auto.
+  constructors; auto.
+  rewrite remove_spec; intuition.
+  Qed.
+
+  Lemma singleton_ok : forall x : elt, Ok (singleton x).
+  Proof.
+  unfold singleton; simpl; constructors; auto. intro; inv.
+  Qed.
+
+  Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x.
+  Proof.
+  unfold singleton; simpl; split; intros. inv; auto. left; auto.
+  Qed.
+
+  Lemma empty_ok : Ok empty.
+  Proof.
+  unfold empty; constructors.
+  Qed.
+
+  Lemma empty_spec : Empty empty.
+  Proof.
+  unfold Empty, empty; red; intros; inv.
+  Qed.
+
+  Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s.
+  Proof.
+  unfold Empty; destruct s; simpl; split; intros; auto.
+  intro; inv.
+  discriminate.
+  elim (H e); auto.
+  Qed.
+
+  Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s.
+  Proof.
+  unfold elements; intuition.
+  Qed.
+
+  Lemma elements_spec2w : forall (s : t) {Hs : Ok s}, NoDup (elements s).
+  Proof.
+  unfold elements; auto.
+  Qed.
+
+  Lemma fold_spec :
+   forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
+   fold f s i = fold_left (flip f) (elements s) i.
+  Proof.
+  reflexivity.
+  Qed.
+
+  Global Instance union_ok s s' `(Ok s, Ok s') : Ok (union s s').
+  Proof.
+  induction s; simpl; auto; intros; inv; unfold flip; auto with *.
+  Qed.
+
+  Lemma union_spec :
+   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
+   In x (union s s') <-> In x s \/ In x s'.
+  Proof.
+  induction s; simpl in *; unfold flip; intros; auto; inv.
+  intuition; inv.
+  rewrite IHs, add_spec, InA_cons; intuition.
+  Qed.
+
+  Global Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s').
+  Proof.
+  unfold inter, fold, flip; intros s.
+  set (acc := nil (A:=elt)).
+  assert (Hacc : Ok acc) by constructors.
+  clearbody acc; revert acc Hacc.
+  induction s; simpl; auto; intros. inv.
+  apply IHs; auto.
+  destruct (mem a s'); auto with *.
+  Qed.
+
+  Lemma inter_spec  :
+   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
+   In x (inter s s') <-> In x s /\ In x s'.
+  Proof.
+  unfold inter, fold, flip; intros.
+  set (acc := nil (A:=elt)) in *.
+  assert (Hacc : Ok acc) by constructors.
+  assert (IFF : (In x s /\ In x s') <-> (In x s /\ In x s') \/ In x acc).
+   intuition; unfold acc in *; inv.
+  rewrite IFF; clear IFF. clearbody acc.
+  revert acc Hacc x s' Hs Hs'.
+  induction s; simpl; intros.
+  intuition; inv.
+  inv.
+  case_eq (mem a s'); intros Hm.
+  rewrite IHs, add_spec, InA_cons; intuition.
+  rewrite mem_spec in Hm; auto.
+  left; split; auto. rewrite H1; auto.
+  rewrite IHs, InA_cons; intuition.
+  rewrite H2, <- mem_spec in H3; auto. congruence.
+  Qed.
+
+  Global Instance diff_ok s s' `(Ok s, Ok s') : Ok (diff s s').
+  Proof.
+  unfold diff; intros s s'; revert s.
+  induction s'; simpl; unfold flip; auto; intros. inv; auto with *.
+  Qed.
+
+  Lemma diff_spec  :
+   forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'},
+   In x (diff s s') <-> In x s /\ ~In x s'.
+  Proof.
+  unfold diff; intros s s'; revert s.
+  induction s'; simpl; unfold flip.
+  intuition; inv.
+  intros. inv.
+  rewrite IHs', remove_spec, InA_cons; intuition.
+  Qed.
+
+  Lemma subset_spec :
+   forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'},
+   subset s s' = true <-> Subset s s'.
+  Proof.
+  unfold subset, Subset; intros.
+  rewrite is_empty_spec.
+  unfold Empty; intros.
+  intuition.
+  specialize (H a). rewrite diff_spec in H; intuition.
+  rewrite <- (mem_spec a) in H |- *. destruct (mem a s'); intuition.
+  rewrite diff_spec in H0; intuition.
+  Qed.
+
+  Lemma equal_spec :
+   forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'},
+   equal s s' = true <-> Equal s s'.
+  Proof.
+  unfold Equal, equal; intros.
+  rewrite andb_true_iff, !subset_spec.
+  unfold Subset; intuition. rewrite <- H; auto. rewrite H; auto.
+  Qed.
+
+  Definition choose_spec1 :
+    forall (s : t) (x : elt), choose s = Some x -> In x s.
+  Proof.
+  destruct s; simpl; intros; inversion H; auto.
+  Qed.
+
+  Definition choose_spec2 : forall s : t, choose s = None -> Empty s.
+  Proof.
+  destruct s; simpl; intros.
+  intros x H0; inversion H0.
+  inversion H.
+  Qed.
+
+  Lemma cardinal_spec :
+   forall (s : t) {Hs : Ok s}, cardinal s = length (elements s).
+  Proof.
+  auto.
+  Qed.
+
+  Lemma filter_spec' : forall s x f,
+   In x (filter f s) -> In x s.
+  Proof.
+  induction s; simpl.
+  intuition; inv.
+  intros; destruct (f a); inv; intuition; right; eauto.
+  Qed.
+
+  Lemma filter_spec :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   (In x (filter f s) <-> In x s /\ f x = true).
+  Proof.
+  induction s; simpl.
+  intuition; inv.
+  intros.
+  destruct (f a) as [ ]_eqn:E; rewrite ?InA_cons, IHs; intuition.
+  setoid_replace x with a; auto.
+  setoid_replace a with x in E; auto. congruence.
+  Qed.
+
+  Global Instance filter_ok s f `(Ok s) : Ok (filter f s).
+  Proof.
+  induction s; simpl.
+  auto.
+  intros; inv.
+  case (f a); auto.
+  constructors; auto.
+  contradict H0.
+  eapply filter_spec'; eauto.
+  Qed.
+
+  Lemma for_all_spec :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Proof.
+  unfold For_all; induction s; simpl.
+  intuition. inv.
+  intros; inv.
+  destruct (f a) as [ ]_eqn:F.
+  rewrite IHs; intuition. inv; auto.
+  setoid_replace x with a; auto.
+  split; intros H'; try discriminate.
+  intros.
+  rewrite <- F, <- (H' a); auto.
+  Qed.
+
+  Lemma exists_spec :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>eq) f ->
+   (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Proof.
+  unfold Exists; induction s; simpl.
+  split; [discriminate| intros (x & Hx & _); inv].
+  intros.
+  destruct (f a) as [ ]_eqn:F.
+  split; auto.
+  exists a; auto.
+  rewrite IHs; firstorder.
+  inv.
+  setoid_replace a with x in F; auto; congruence.
+  exists x; auto.
+  Qed.
+
+  Lemma partition_spec1 :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>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_spec2 :
+   forall (s : t) (f : elt -> bool),
+   Proper (X.eq==>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_ok1' :
+   forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt),
+    In x (fst (partition f s)) -> In x s.
+  Proof.
+  induction s; simpl; auto; intros. inv.
+  generalize (IHs H1 f x).
+  destruct (f a); destruct (partition f s); simpl in *; auto.
+  inversion_clear H; auto.
+  Qed.
+
+  Lemma partition_ok2' :
+   forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt),
+    In x (snd (partition f s)) -> In x s.
+  Proof.
+  induction s; simpl; auto; intros. inv.
+  generalize (IHs H1 f x).
+  destruct (f a); destruct (partition f s); simpl in *; auto.
+  inversion_clear H; auto.
+  Qed.
+
+  Global Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec f Hs; inv.
+  generalize (@partition_ok1' _ _ f x).
+  generalize (Hrec f H0).
+  case (f x); case (partition f l); simpl; constructors; auto.
+  Qed.
+
+  Global Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)).
+  Proof.
+  simple induction s; simpl.
+  auto.
+  intros x l Hrec f Hs; inv.
+  generalize (@partition_ok2' _ _ f x).
+  generalize (Hrec f H0).
+  case (f x); case (partition f l); simpl; constructors; auto.
+  Qed.
+
+  End ForNotations.
+
+  Definition In := InA X.eq.
+  Definition eq := Equal.
+  Instance eq_equiv : Equivalence eq.
+
+End MakeRaw.
+
+(** * 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) <: WSets with Module E := X.
+ Module Raw := MakeRaw X.
+ Include WRaw2Sets X Raw.
+End Make.
+
diff --git a/theories/MSets/MSets.v b/theories/MSets/MSets.v
new file mode 100644
index 000000000..42966c7fc
--- /dev/null
+++ b/theories/MSets/MSets.v
@@ -0,0 +1,23 @@
+(***********************************************************************)
+(*  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$ *)
+
+Require Export OrderedType2.
+Require Export OrderedType2Ex.
+Require Export OrderedType2Alt.
+Require Export DecidableType2.
+Require Export DecidableType2Ex.
+Require Export MSetInterface.
+Require Export MSetFacts.
+Require Export MSetDecide.
+Require Export MSetProperties.
+Require Export MSetEqProperties.
+Require Export MSetWeakList.
+Require Export MSetList.
+Require Export MSetAVL.
\ No newline at end of file
diff --git a/theories/Logic/DecidableType.v b/theories/Structures/DecidableType.v
index 625f776bf..625f776bf 100644
--- a/theories/Logic/DecidableType.v
+++ b/theories/Structures/DecidableType.v
diff --git a/theories/Structures/DecidableType2.v b/theories/Structures/DecidableType2.v
new file mode 100644
index 000000000..0b3ebfa29
--- /dev/null
+++ b/theories/Structures/DecidableType2.v
@@ -0,0 +1,164 @@
+(***********************************************************************)
+(*  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$ *)
+
+Require Export SetoidList2.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Types with Equalities, and nothing more (for subtyping purpose) *)
+
+Module Type EqualityType.
+  Parameter Inline t : Type.
+  Parameter Inline eq : t -> t -> Prop.
+  Instance eq_equiv : Equivalence eq.
+
+  Hint Resolve (@Equivalence_Reflexive _ _ eq_equiv).
+  Hint Resolve (@Equivalence_Transitive _ _ eq_equiv).
+  Hint Immediate (@Equivalence_Symmetric _ _ eq_equiv).
+End EqualityType.
+
+(** * Types with decidable Equalities (but no ordering) *)
+
+Module Type DecidableType.
+  Include Type EqualityType.
+  Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }.
+End DecidableType.
+
+(** * Additional notions about keys and datas used in FMap *)
+
+Module KeyDecidableType(D:DecidableType).
+ Import D.
+
+ Section Elt.
+ Variable elt : Type.
+ 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').
+
+  Global Hint Unfold eqk eqke.
+  Global 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 *)
+
+  Instance eqk_equiv : Equivalence eqk.
+  Proof.
+   constructor; eauto.
+  Qed.
+
+  Instance eqke_equiv : Equivalence eqke.
+  Proof.
+   constructor. auto.
+   red; unfold eqke; intuition.
+   red; unfold eqke; intuition; [ eauto | congruence ].
+  Qed.
+
+  Global Hint Resolve (@Equivalence_Reflexive _ _ eqk_equiv).
+  Global Hint Resolve (@Equivalence_Transitive _ _ eqk_equiv).
+  Global Hint Immediate (@Equivalence_Symmetric _ _ eqk_equiv).
+  Global Hint Resolve (@Equivalence_Reflexive _ _ eqke_equiv).
+  Global Hint Resolve (@Equivalence_Transitive _ _ eqke_equiv).
+  Global Hint Immediate (@Equivalence_Symmetric _ _ eqke_equiv).
+
+  Lemma InA_eqke_eqk :
+     forall x m, InA eqke x m -> InA eqk x m.
+  Proof.
+    unfold eqke; induction 1; intuition.
+  Qed.
+  Global 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. rewrite <- H; auto.
+  Qed.
+
+  Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
+  Definition In k m := exists e:elt, MapsTo k e m.
+
+  Global 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.
+
+  Global Instance MapsTo_compat :
+    Proper (eq==>Logic.eq==>Logic.eq==>iff) MapsTo.
+  Proof.
+  intros x x' Hxx' e e' Hee' l l' Hll'; subst.
+  unfold MapsTo.
+  assert (EQN : eqke (x,e') (x',e')) by (compute;auto).
+  rewrite EQN; intuition.
+  Qed.
+
+  Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
+  Proof.
+  intros; rewrite <- H; auto.
+  Qed.
+
+  Global Instance In_compat : Proper (eq==>Logic.eq==>iff) In.
+  Proof.
+  intros x x' Hxx' l l' Hll'; subst l.
+  unfold In.
+  split; intros (e,He); exists e.
+  rewrite <- Hxx'; auto.
+  rewrite Hxx'; auto.
+  Qed.
+
+  Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
+  Proof.
+  intros; rewrite <- H; auto.
+  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 Resolve In_inv_2 In_inv_3.
+
+End KeyDecidableType.
+
+
+
+
+
diff --git a/theories/Structures/DecidableType2Ex.v b/theories/Structures/DecidableType2Ex.v
new file mode 100644
index 000000000..7b9c052ec
--- /dev/null
+++ b/theories/Structures/DecidableType2Ex.v
@@ -0,0 +1,85 @@
+(***********************************************************************)
+(*  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$ *)
+
+Require Import DecidableType2.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Examples of Decidable Type structures. *)
+
+(** A particular case of [DecidableType] where
+    the equality is the usual one of Coq. *)
+
+Module Type UsualDecidableType.
+ Parameter Inline t : Type.
+ Definition eq := @eq t.
+ Program Instance eq_equiv : Equivalence eq.
+ Parameter eq_dec : forall x y, { eq x y }+{~eq x y }.
+End UsualDecidableType.
+
+(** a [UsualDecidableType] is in particular an [DecidableType]. *)
+
+Module UDT_to_DT (U:UsualDecidableType) <: DecidableType := U.
+
+(** an shortcut for easily building a UsualDecidableType *)
+
+Module Type MiniDecidableType.
+ Parameter Inline t : Type.
+ Parameter eq_dec : forall x y:t, { x=y }+{ x<>y }.
+End MiniDecidableType.
+
+Module Make_UDT (M:MiniDecidableType) <: UsualDecidableType.
+ Definition t:=M.t.
+ Definition eq := @eq t.
+ Program Instance eq_equiv : Equivalence eq.
+ Definition eq_dec := M.eq_dec.
+End Make_UDT.
+
+(** From two decidable types, we can build a new DecidableType
+   over their cartesian product. *)
+
+Module PairDecidableType(D1 D2:DecidableType) <: DecidableType.
+
+ Definition t := prod D1.t D2.t.
+
+ Definition eq x y := D1.eq (fst x) (fst y) /\ D2.eq (snd x) (snd y).
+
+ Instance eq_equiv : Equivalence eq.
+ Proof.
+ constructor.
+ intros (x1,x2); red; simpl; auto.
+ intros (x1,x2) (y1,y2); unfold eq; simpl; intuition.
+ intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto.
+ Qed.
+
+ Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
+ Proof.
+ intros (x1,x2) (y1,y2); unfold eq; simpl.
+ destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); intuition.
+ Defined.
+
+End PairDecidableType.
+
+(** Similarly for pairs of UsualDecidableType *)
+
+Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType.
+ Definition t := prod D1.t D2.t.
+ Definition eq := @eq t.
+ Program Instance eq_equiv : Equivalence eq.
+ Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
+ Proof.
+ intros (x1,x2) (y1,y2);
+ destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2);
+ unfold eq, D1.eq, D2.eq in *; simpl;
+ (left; f_equal; auto; fail) ||
+ (right; intro H; injection H; auto).
+ Defined.
+
+End PairUsualDecidableType.
diff --git a/theories/Logic/DecidableTypeEx.v b/theories/Structures/DecidableTypeEx.v
index 022102f70..022102f70 100644
--- a/theories/Logic/DecidableTypeEx.v
+++ b/theories/Structures/DecidableTypeEx.v
diff --git a/theories/FSets/OrderedType.v b/theories/Structures/OrderedType.v
index f17eb43a9..f17eb43a9 100644
--- a/theories/FSets/OrderedType.v
+++ b/theories/Structures/OrderedType.v
diff --git a/theories/Structures/OrderedType2.v b/theories/Structures/OrderedType2.v
new file mode 100644
index 000000000..e1b7f4e22
--- /dev/null
+++ b/theories/Structures/OrderedType2.v
@@ -0,0 +1,680 @@
+(***********************************************************************)
+(*  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$ *)
+
+Require Export SetoidList2 DecidableType2.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Ordered types *)
+
+Definition Cmp (A:Type)(eq lt : relation A) c :=
+ match c with
+  | Eq => eq
+  | Lt => lt
+  | Gt => flip lt
+ end.
+
+Module Type MiniOrderedType.
+  Include Type EqualityType.
+
+  Parameter Inline lt : t -> t -> Prop.
+  Instance lt_strorder : StrictOrder lt.
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+
+  Parameter compare : t -> t -> comparison.
+  Axiom compare_spec : forall x y, Cmp eq lt (compare x y) x y.
+
+End MiniOrderedType.
+
+Module Type OrderedType.
+  Include Type MiniOrderedType.
+
+  (** A [eq_dec] can be deduced from [compare] below. But adding this
+     redundant field allows to see an OrderedType as a DecidableType. *)
+  Parameter eq_dec : forall x y, { eq x y } + { ~ eq x y }.
+
+End OrderedType.
+
+Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType.
+  Include O.
+
+  Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
+  Proof.
+   intros.
+   generalize (compare_spec x y); destruct (compare x y);
+    unfold Cmp, flip; intros.
+    left; auto.
+    right. intro H'; rewrite <- H' in H.
+      apply (StrictOrder_Irreflexive x); auto.
+    right. intro H'; rewrite <- H' in H.
+      apply (StrictOrder_Irreflexive x); auto.
+  Defined.
+
+End MOT_to_OT.
+
+(** * Ordered types properties *)
+
+(** Additional properties that can be derived from signature
+    [OrderedType]. *)
+
+Module OrderedTypeFacts (Import O: OrderedType).
+
+  Infix "==" := eq (at level 70, no associativity) : order.
+  Infix "<" := lt : order.
+  Notation "x <= y" := (~lt y x) : order.
+  Infix "?=" := compare (at level 70, no associativity) : order.
+
+  Local Open Scope order.
+
+  (** The following lemmas are re-phrasing of eq_equiv and lt_strorder.
+      Interest: compatibility, simple use (e.g. in tactic order), etc. *)
+
+  Definition eq_refl (x:t) : x==x := Equivalence_Reflexive x.
+
+  Definition eq_sym (x y:t) : x==y -> y==x := Equivalence_Symmetric x y.
+
+  Definition eq_trans (x y z:t) : x==y -> y==z -> x==z :=
+   Equivalence_Transitive x y z.
+
+  Definition lt_trans (x y z:t) : x<y -> y<z -> x<z :=
+   StrictOrder_Transitive x y z.
+
+  Definition lt_antirefl (x:t) : ~x<x := StrictOrder_Irreflexive x.
+
+  Lemma lt_not_eq : forall x y, x<y -> ~x==y.
+  Proof.
+   intros x y H H'. rewrite H' in H.
+   apply lt_antirefl with y; auto.
+  Qed.
+
+  Lemma lt_eq : forall x y z, x<y -> y==z -> x<z.
+  Proof.
+   intros x y z H H'. rewrite <- H'; auto.
+  Qed.
+
+  Lemma eq_lt : forall x y z, x==y -> y<z -> x<z.
+  Proof.
+   intros x y z H H'. rewrite H; auto.
+  Qed.
+
+  Lemma le_eq : forall x y z, x<=y -> y==z -> x<=z.
+  Proof.
+   intros x y z H H' H''. rewrite H' in H; auto.
+  Qed.
+
+  Lemma eq_le : forall x y z, x==y -> y<=z -> x<=z.
+  Proof.
+   intros x y z H H'. rewrite H; auto.
+  Qed.
+
+  Lemma neq_eq : forall x y z, ~x==y -> y==z -> ~x==z.
+  Proof.
+   intros x y z H H'; rewrite <-H'; auto.
+  Qed.
+
+  Lemma eq_neq : forall x y z, x==y -> ~y==z -> ~x==z.
+  Proof.
+   intros x y z H H'; rewrite H; auto.
+  Qed.
+
+  Hint Resolve eq_trans eq_refl lt_trans.
+  Hint Immediate eq_sym eq_lt lt_eq le_eq eq_le neq_eq eq_neq.
+
+  Ltac elim_compare x y :=
+   generalize (compare_spec x y); destruct (compare x y);
+   unfold Cmp, flip.
+
+  Lemma le_lt_trans : forall x y z, x<=y -> y<z -> x<z.
+  Proof.
+   intros. elim_compare x y; intro H'.
+   rewrite H'; auto.
+   transitivity y; auto.
+   intuition.
+  Qed.
+
+  Lemma lt_le_trans : forall x y z, x<y -> y<=z -> x<z.
+  Proof.
+   intros. elim_compare y z; intro H'.
+   rewrite <- H'; auto.
+   transitivity y; auto.
+   intuition.
+  Qed.
+
+  Lemma le_trans : forall x y z, x<=y -> y<=z -> x<=z.
+  Proof.
+   intros x y z Hxy Hyz Hzx.
+   apply Hxy.
+   eapply le_lt_trans; eauto.
+  Qed.
+
+  Lemma le_antisym : forall x y, x<=y -> y<=x -> x==y.
+  Proof.
+   intros. elim_compare x y; intuition.
+  Qed.
+
+  Lemma le_neq : forall x y, x<=y -> ~x==y -> x<y.
+  Proof.
+   intros. elim_compare x y; intuition.
+  Qed.
+
+  Lemma neq_sym : forall x y, ~x==y -> ~y==x.
+  Proof.
+   intuition.
+  Qed.
+
+(** The order tactic *)
+
+(** This tactic is designed to solve systems of (in)equations
+    involving eq and lt and ~eq and ~lt (i.e. ge). All others
+    parts of the goal will be discarded. This tactic is
+    domain-agnostic : it will only use equivalence+order axioms.
+    Moreover it doesn't directly use totality of the order
+    (but uses above lemmas such as le_trans that rely on it).
+    A typical use of this tactic is transitivity problems. *)
+
+Definition hide_eq := eq.
+
+(** order_eq : replace x by y in all (in)equations thanks
+   to equality EQ (where eq has been hidden in order to avoid
+   self-rewriting).
+
+   NB: order_saturate_eq could be written in a shorter way thanks
+   to rewrite, but proof terms would be uglier *)
+
+Ltac order_eq x y EQ :=
+ let rewr H t := generalize t; clear H; intro H
+ in
+ match goal with
+ | H : x == _ |- _ => rewr H (eq_trans (eq_sym EQ) H); order_eq x y EQ
+ | H : _ == x |- _ => rewr H (eq_trans H EQ); order_eq x y EQ
+ | H : ~x == _ |- _ => rewr H (eq_neq (eq_sym EQ) H); order_eq x y EQ
+ | H : ~_ == x |- _ => rewr H (neq_eq H EQ); order_eq x y EQ
+ | H : x < ?z |- _ => rewr H (eq_lt (eq_sym EQ) H); order_eq x y EQ
+ | H : ?z < x |- _ => rewr H (lt_eq H EQ); order_eq x y EQ
+ | H : x <= ?z |- _ => rewr H (eq_le (eq_sym EQ) H); order_eq x y EQ
+ | H : ?z <= x |- _ => rewr H (le_eq H EQ); order_eq x y EQ
+ (* NB: no negation in the goal, see below *)
+ | |- x == ?z => apply eq_trans with y; [apply EQ| ]; order_eq x y EQ
+ | |- ?z == x => apply eq_trans with y; [ | apply (eq_sym EQ) ];
+    order_eq x y EQ
+ | |- x < ?z => apply eq_lt with y; [apply EQ| ]; order_eq x y EQ
+ | |- ?z < x => apply lt_eq with y; [ | apply (eq_sym EQ) ];
+    order_eq x y EQ
+ | _ => clear EQ
+end.
+
+Ltac order := intros; trivial;
+ match goal with
+ | |- ~ _ => intro; order
+ | H : ?A -> False |- _ => change (~A) in H; order
+ (* First, successful situations *)
+ | H : ?x < ?x |- _ => elim (lt_antirefl H)
+ | H : ~ ?x == ?x |- _ => elim (H (Equivalence_Reflexive x))
+ | |- ?x == ?x => apply (Equivalence_Reflexive x)
+ (* Second, useless hyps or goal *)
+ | H : ?x == ?x |- _ => clear H; order
+ | H : ?x <= ?x |- _ => clear H; order
+ | |- ?x < ?x => elimtype False; order
+ (* We eliminate equalities *)
+ | H : ?x == ?y |- _ =>
+   change (hide_eq x y) in H; order_eq x y H; order
+ (* Simultaneous le and ge is eq *)
+ | H1 : ?x <= ?y, H2 : ?y <= ?x |- _ =>
+   generalize (le_antisym H1 H2); clear H1 H2; intro; order
+ (* Simultaneous le and ~eq is lt *)
+ | H1: ?x <= ?y, H2: ~ ?x == ?y |- _ =>
+     generalize (le_neq H1 H2); clear H1 H2; intro; order
+ | H1: ?x <= ?y, H2: ~ ?y == ?x |- _ =>
+     generalize (le_neq H1 (neq_sym H2)); clear H1 H2; intro; order
+ (* Transitivity of lt and le *)
+ | H1 : ?x < ?y, H2 : ?y < ?z |- _ =>
+    match goal with
+      | H : x < z |- _ => fail 1
+      | _ => generalize (lt_trans H1 H2); intro; order
+    end
+ | H1 : ?x <= ?y, H2 : ?y < ?z |- _ =>
+    match goal with
+      | H : x < z |- _ => fail 1
+      | _ => generalize (le_lt_trans H1 H2); intro; order
+    end
+ | H1 : ?x < ?y, H2 : ?y <= ?z |- _ =>
+    match goal with
+      | H : x < z |- _ => fail 1
+      | _ => generalize (lt_le_trans H1 H2); intro; order
+    end
+ | H1 : ?x <= ?y, H2 : ?y <= ?z |- _ =>
+    match goal with
+      | H : x <= z |- _ => fail 1
+      | _ => generalize (le_trans H1 H2); intro; order
+    end
+ | _ => auto; fail
+end.
+
+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 compare_eq_iff : forall x y, (x ?= y) = Eq <-> x==y.
+  Proof.
+   intros; elim_compare x y; intuition; try discriminate; order.
+  Qed.
+
+  Lemma compare_lt_iff : forall x y, (x ?= y) = Lt <-> x<y.
+  Proof.
+   intros; elim_compare x y; intuition; try discriminate; order.
+  Qed.
+
+  Lemma compare_gt_iff : forall x y, (x ?= y) = Gt <-> y<x.
+  Proof.
+   intros; elim_compare x y; intuition; try discriminate; order.
+  Qed.
+
+  Lemma compare_ge_iff : forall x y, (x ?= y) <> Lt <-> y<=x.
+  Proof.
+   intros; rewrite compare_lt_iff; intuition.
+  Qed.
+
+  Lemma compare_le_iff : forall x y, (x ?= y) <> Gt <-> x<=y.
+  Proof.
+   intros; rewrite compare_gt_iff; intuition.
+  Qed.
+
+  Hint Rewrite compare_eq_iff compare_lt_iff compare_gt_iff : order.
+
+  Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare.
+  Proof.
+  intros x x' Hxx' y y' Hyy'.
+  elim_compare x' y'; intros; autorewrite with order; order.
+  Qed.
+
+  Lemma compare_refl : forall x, (x ?= x) = Eq.
+  Proof.
+   intros; elim_compare x x; auto; order.
+  Qed.
+
+  Lemma compare_antisym : forall x y, (y ?= x) = CompOpp (x ?= y).
+  Proof.
+   intros; elim_compare x y; simpl; intros; autorewrite with order; order.
+  Qed.
+
+  (** For compatibility reasons *)
+  Definition eq_dec := eq_dec.
+
+  Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}.
+  Proof.
+   intros; elim_compare x y; [ right | left | right ]; auto.
+  Defined.
+
+  Definition eqb x y : bool := if eq_dec x y then true else false.
+
+  Lemma if_eq_dec : forall x y (B:Type)(b b':B),
+    (if eq_dec x y then b else b') =
+    (match compare x y with Eq => b | _ => b' end).
+  Proof.
+  intros; destruct eq_dec; elim_compare x y; auto; order.
+  Qed.
+
+  Lemma eqb_alt :
+    forall x y, eqb x y = match compare x y with Eq => true | _ => false end.
+  Proof.
+  unfold eqb; intros; apply if_eq_dec.
+  Qed.
+
+  Instance eqb_compat : Proper (eq==>eq==>Logic.eq) eqb.
+  Proof.
+  intros x x' Hxx' y y' Hyy'.
+  rewrite 2 eqb_alt, Hxx', Hyy'; auto.
+  Qed.
+
+
+(* Specialization of resuts about lists modulo. *)
+
+Section ForNotations.
+
+Notation In:=(InA eq).
+Notation Inf:=(lelistA lt).
+Notation Sort:=(sort lt).
+Notation NoDup:=(NoDupA eq).
+
+Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
+Proof. intros. rewrite <- H; auto. Qed.
+
+Lemma ListIn_In : forall l x, List.In x l -> In x l.
+Proof. exact (In_InA eq_equiv). Qed.
+
+Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l.
+Proof. exact (InfA_ltA lt_strorder). Qed.
+
+Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l.
+Proof. exact (InfA_eqA eq_equiv lt_strorder lt_compat). 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_equiv lt_strorder lt_compat). 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_equiv (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_equiv lt_strorder lt_compat). Qed.
+
+Lemma Sort_NoDup : forall l, Sort l -> NoDup l.
+Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat) . Qed.
+
+End ForNotations.
+
+Hint Resolve ListIn_In Sort_NoDup Inf_lt.
+Hint Immediate In_eq Inf_lt.
+
+End OrderedTypeFacts.
+
+Definition ProdRel {A B}(RA:relation A)(RB:relation B) : relation (A*B) :=
+ fun p p' => RA (fst p) (fst p') /\ RB (snd p) (snd p').
+
+Definition FstRel {A B}(R:relation A) : relation (A*B) :=
+ fun p p' => R (fst p) (fst p').
+
+Definition SndRel {A B}(R:relation B) : relation (A*B) :=
+ fun p p' => R (snd p) (snd p').
+
+Instance ProdRel_equiv {A B} `(Equivalence A RA)`(Equivalence B RB) :
+ Equivalence (ProdRel RA RB).
+Proof. firstorder. Qed.
+
+Instance FstRel_equiv {A B} `(Equivalence A RA) :
+ Equivalence (FstRel RA (B:=B)).
+Proof. firstorder. Qed.
+
+Instance SndRel_equiv {A B} `(Equivalence B RB) :
+ Equivalence (SndRel RB (A:=A)).
+Proof. firstorder. Qed.
+
+Instance FstRel_strorder {A B} `(StrictOrder A RA) :
+ StrictOrder (FstRel RA (B:=B)).
+Proof. firstorder. Qed.
+
+Instance SndRel_strorder {A B} `(StrictOrder B RB) :
+ StrictOrder (SndRel RB (A:=A)).
+Proof. firstorder. Qed.
+
+Lemma FstRel_ProdRel {A B}(RA:relation A) : forall p p':A*B,
+ (FstRel RA) p p' <-> (ProdRel RA (fun _ _ =>True)) p p'.
+Proof. firstorder. Qed.
+
+Lemma SndRel_ProdRel {A B}(RB:relation B) : forall p p':A*B,
+ (SndRel RB) p p' <-> (ProdRel (fun _ _ =>True) RB) p p'.
+Proof. firstorder. Qed.
+
+Lemma ProdRel_alt {A B}(RA:relation A)(RB:relation B) : forall p p':A*B,
+ (ProdRel RA RB) p p' <-> relation_conjunction (FstRel RA) (SndRel RB) p p'.
+Proof. firstorder. Qed.
+
+Instance FstRel_compat {A B} (R : relation A)`(Proper _ (Ri==>Ri==>Ro) R) :
+ Proper (FstRel Ri==>FstRel Ri==>Ro) (FstRel R (B:=B)).
+Proof.
+ intros A B R Ri Ro H (a1,b1) (a1',b1') Hab1 (a2,b2) (a2',b2') Hab2.
+ unfold FstRel in *; simpl in *. apply H; auto.
+Qed.
+
+Instance SndRel_compat {A B} (R : relation B)`(Proper _ (Ri==>Ri==>Ro) R) :
+ Proper (SndRel Ri==>SndRel Ri==>Ro) (SndRel R (A:=A)).
+Proof.
+ intros A B R Ri Ro H (a1,b1) (a1',b1') Hab1 (a2,b2) (a2',b2') Hab2.
+ unfold SndRel in *; simpl in *. apply H; auto.
+Qed.
+
+Instance FstRel_sub {A B} (RA:relation A)(RB:relation B):
+ subrelation (ProdRel RA RB) (FstRel RA).
+Proof. firstorder. Qed.
+
+Instance SndRel_sub {A B} (RA:relation A)(RB:relation B):
+ subrelation (ProdRel RA RB) (SndRel RB).
+Proof. firstorder. Qed.
+
+Instance pair_compat { A B } (RA:relation A)(RB : relation B) :
+ Proper (RA==>RB==>ProdRel RA RB) (@pair A B).
+Proof. firstorder. Qed.
+
+
+Hint Unfold ProdRel FstRel SndRel.
+Hint Extern 2 (ProdRel _ _ _ _) => split.
+
+
+Module KeyOrderedType(Import O:OrderedType).
+ Module Import MO:=OrderedTypeFacts(O).
+
+ Section Elt.
+ Variable elt : Type.
+ Notation key:=t.
+
+  Definition eqk : relation (key*elt) := FstRel eq.
+  Definition eqke : relation (key*elt) := ProdRel eq Logic.eq.
+  Definition ltk : relation (key*elt) := FstRel lt.
+
+  Hint Unfold eqk eqke ltk.
+
+  (* eqke is stricter than eqk *)
+
+  Global Instance eqke_eqk : subrelation eqke eqk.
+  Proof. unfold eqke, eqk; auto with *. 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 *)
+
+  Global Instance eqk_equiv : Equivalence eqk.
+
+  Global Instance eqke_equiv : Equivalence eqke.
+
+  Global Instance ltk_strorder : StrictOrder ltk.
+
+  Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk.
+  Proof. unfold eqk, ltk; auto with *. Qed.
+
+  (* Additionnal facts *)
+
+  Global Instance pair_compat : Proper (eq==>Logic.eq==>eqke) (@pair key elt).
+  Proof. unfold eqke; auto with *. Qed.
+
+  Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'.
+  Proof.
+  intros e e' LT EQ; rewrite EQ in LT.
+  elim (StrictOrder_Irreflexive _ LT).
+  Qed.
+
+  Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'.
+  Proof.
+  intros e e' LT EQ; rewrite EQ in LT.
+  elim (StrictOrder_Irreflexive _ LT).
+  Qed.
+
+  Lemma InA_eqke_eqk :
+     forall x m, InA eqke x m -> InA eqk x m.
+  Proof.
+    unfold eqke, ProdRel; 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; compute in H.
+  exists e; auto.
+  destruct IHInA as [e H0].
+  exists e; auto.
+  Qed.
+
+  Lemma In_alt2 : forall k l, In k l <-> ExistsL (fun p => eq k (fst p)) l.
+  Proof.
+  unfold In, MapsTo.
+  setoid_rewrite ExistsL_exists; setoid_rewrite InA_alt.
+  firstorder.
+  exists (snd x), x; auto.
+  Qed.
+
+  Lemma In_nil : forall k, In k nil <-> False.
+  Proof.
+  intros; rewrite In_alt2; apply ExistsL_nil.
+  Qed.
+
+  Lemma In_cons : forall k p l,
+   In k (p::l) <-> eq k (fst p) \/ In k l.
+  Proof.
+  intros; rewrite !In_alt2, ExistsL_cons; intuition.
+  Qed.
+
+  Global Instance MapsTo_compat :
+   Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo.
+  Proof.
+  intros x x' Hx e e' He l l' Hl. unfold MapsTo.
+  rewrite Hx, He, Hl; intuition.
+  Qed.
+
+  Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In.
+  Proof.
+  intros x x' Hx l l' Hl. rewrite !In_alt.
+  setoid_rewrite Hl. setoid_rewrite Hx. intuition.
+  Qed.
+
+  Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
+  Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed.
+
+  Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
+  Proof. intros l x y EQ. rewrite <- EQ; auto. Qed.
+
+  Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l.
+  Proof. intros l x x' H. rewrite H; auto. Qed.
+
+  Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l.
+  Proof. apply InfA_ltA; auto with *. 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. apply SortA_InfA_InA; auto with *. 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_NoDupA: forall l, Sort l -> NoDupA eqk l.
+  Proof. apply SortA_NoDupA; auto with *. Qed.
+
+  Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'.
+  Proof.
+   intros; invlist sort; 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.
+    intros; invlist InA; 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.
+    intros; invlist sort; red; intros.
+    eapply Sort_Inf_NotIn; eauto using In_eq.
+  Qed.
+
+  Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
+  Proof.
+    intros; invlist In; invlist MapsTo. compute in * |- ; intuition.
+    right; exists x; auto.
+  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.
+   intros; invlist InA; intuition.
+  Qed.
+
+  Lemma In_inv_3 : forall x x' l,
+      InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
+  Proof.
+   intros; invlist InA; compute in * |- ; intuition.
+  Qed.
+
+ End Elt.
+
+ Hint Resolve (fun elt => @Equivalence_Reflexive _ _ (eqk_equiv elt)).
+ Hint Resolve (fun elt => @Equivalence_Transitive _ _ (eqk_equiv elt)).
+ Hint Immediate (fun elt => @Equivalence_Symmetric _ _ (eqk_equiv elt)).
+ Hint Resolve (fun elt => @Equivalence_Reflexive _ _ (eqke_equiv elt)).
+ Hint Resolve (fun elt => @Equivalence_Transitive _ _ (eqke_equiv elt)).
+ Hint Immediate (fun elt => @Equivalence_Symmetric _ _ (eqke_equiv elt)).
+ Hint Resolve (fun elt => @StrictOrder_Transitive _ _ (ltk_strorder elt)).
+
+ Hint Unfold eqk eqke ltk.
+ Hint Extern 2 (eqke ?a ?b) => split.
+ Hint Resolve ltk_not_eqk ltk_not_eqke.
+ 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 KeyOrderedType.
diff --git a/theories/Structures/OrderedType2Alt.v b/theories/Structures/OrderedType2Alt.v
new file mode 100644
index 000000000..43b3d05f8
--- /dev/null
+++ b/theories/Structures/OrderedType2Alt.v
@@ -0,0 +1,297 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id$ *)
+
+Require Import OrderedType2.
+Set Implicit Arguments.
+
+(** NB: Instead of [comparison], defined in [Datatypes.v] which is [Eq|Lt|Gt],
+  we used historically the dependent type [compare] which is
+  [EQ _ | LT _ | GT _ ]
+*)
+
+Inductive Compare (X : Type) (lt eq : X -> X -> Prop) (x y : X) : Type :=
+  | LT : lt x y -> Compare lt eq x y
+  | EQ : eq x y -> Compare lt eq x y
+  | GT : lt y x -> Compare lt eq x y.
+
+(** * Some alternative (but equivalent) presentations for an Ordered Type
+   inferface. *)
+
+(** ** The original interface *)
+
+Module Type OrderedTypeOrig.
+  Parameter Inline t : Type.
+
+  Parameter Inline 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 Inline lt : t -> t -> Prop.
+  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.
+
+End OrderedTypeOrig.
+
+(** ** An interface based on compare *)
+
+Module Type OrderedTypeAlt.
+
+ Parameter t : Type.
+
+ Parameter compare : t -> t -> comparison.
+
+ Infix "?=" := compare (at level 70, no associativity).
+
+ Parameter compare_sym :
+   forall x y, (y?=x) = CompOpp (x?=y).
+ Parameter compare_trans :
+   forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
+
+End OrderedTypeAlt.
+
+(** ** From OrderedTypeOrig to OrderedType. *)
+
+Module OrderedType_from_Orig (O:OrderedTypeOrig) <: OrderedType.
+
+ Import O.
+ Definition t := O.t.
+ Definition eq := O.eq.
+ Instance eq_equiv : Equivalence eq.
+ Proof.
+  split; red; [ apply eq_refl | apply eq_sym | eapply eq_trans ].
+ Qed.
+
+ Definition lt := O.lt.
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+  split; repeat red; intros.
+  eapply lt_not_eq; eauto.
+  eapply lt_trans; eauto.
+ 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 x y); eauto.
+  elim (@lt_not_eq z y); eauto using lt_trans.
+ 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 y z); eauto.
+  elim (@lt_not_eq y x); eauto using lt_trans.
+ Qed.
+
+ Instance lt_compat : Proper (eq==>eq==>iff) lt.
+ Proof.
+  apply proper_sym_impl_iff_2; auto with *.
+  repeat red; intros.
+  eapply lt_eq; eauto. eapply eq_lt; eauto. symmetry; auto.
+ Qed.
+
+ Definition compare x y :=
+   match O.compare x y with
+    | EQ _ => Eq
+    | LT _ => Lt
+    | GT _ => Gt
+  end.
+
+ Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y.
+ Proof.
+  intros; unfold compare; destruct O.compare; auto.
+ Qed.
+
+ Definition eq_dec : forall x y, { eq x y } + { ~eq x y }.
+ Proof.
+  intros; destruct (O.compare x y).
+  right. apply lt_not_eq; auto.
+  left; auto.
+  right. intro. apply (@lt_not_eq y x); auto.
+ Defined.
+
+End OrderedType_from_Orig.
+
+(** ** From OrderedType to OrderedTypeOrig. *)
+
+Module OrderedType_to_Orig (O:OrderedType) <: OrderedTypeOrig.
+
+ Import O.
+ Definition t := t.
+ Definition eq := eq.
+ Definition lt := lt.
+
+ Lemma eq_refl : Reflexive eq.
+ Proof. auto. Qed.
+ Lemma eq_sym : Symmetric eq.
+ Proof. apply eq_equiv. Qed.
+ Lemma eq_trans : Transitive eq.
+ Proof. apply eq_equiv. Qed.
+
+ Lemma lt_not_eq : forall x y, lt x y -> ~eq x y.
+ Proof.
+  intros x y L E; rewrite E in L. apply (StrictOrder_Irreflexive y); auto.
+ Qed.
+
+ Lemma lt_trans : Transitive lt.
+ Proof. apply lt_strorder. Qed.
+
+ Definition compare : forall x y, Compare lt eq x y.
+ Proof.
+  intros. generalize (compare_spec x y); unfold Cmp, flip.
+  destruct (compare x y); [apply EQ|apply LT|apply GT]; auto.
+ Defined.
+
+ Definition eq_dec := eq_dec.
+
+End OrderedType_to_Orig.
+
+
+(** ** From OrderedTypeAlt to OrderedType. *)
+
+Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType.
+ Import O.
+
+ Definition t := t.
+
+ Definition eq x y := (x?=y) = Eq.
+ Definition lt x y := (x?=y) = Lt.
+
+ Instance eq_equiv : Equivalence eq.
+ Proof.
+  split; red.
+  (* refl *)
+  unfold eq; intros x.
+  assert (H:=compare_sym x x).
+  destruct (x ?= x); simpl in *; auto; discriminate.
+  (* sym *)
+  unfold eq; intros x y H.
+  rewrite compare_sym, H; simpl; auto.
+  (* trans *)
+  apply compare_trans.
+ Qed.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+  split; repeat red; unfold lt; try apply compare_trans.
+  intros x H.
+  assert (eq x x) by reflexivity.
+  unfold eq in *; congruence.
+ Qed.
+
+ Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z.
+ Proof.
+  unfold lt, eq; intros x y z Hxy Hyz.
+  destruct (compare x z) as [ ]_eqn:Hxz; auto.
+  rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz.
+  rewrite (compare_trans Hxz Hyz) in Hxy; discriminate.
+  rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy.
+  rewrite (compare_trans Hxy Hxz) in Hyz; discriminate.
+ Qed.
+
+ Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z.
+ Proof.
+  unfold lt, eq; intros x y z Hxy Hyz.
+  destruct (compare x z) as [ ]_eqn:Hxz; auto.
+  rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy.
+  rewrite (compare_trans Hxy Hxz) in Hyz; discriminate.
+  rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz.
+  rewrite (compare_trans Hxz Hyz) in Hxy; discriminate.
+ Qed.
+
+ Instance lt_compat : Proper (eq==>eq==>iff) lt.
+ Proof.
+  apply proper_sym_impl_iff_2; auto with *.
+  repeat red; intros.
+  eapply lt_eq; eauto. eapply eq_lt; eauto. symmetry; auto.
+ Qed.
+
+ Definition compare := O.compare.
+
+ Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y.
+ Proof.
+  unfold Cmp, flip, eq, lt, compare; intros.
+  destruct (O.compare x y) as [ ]_eqn:H; auto.
+  rewrite compare_sym, H; auto.
+ Qed.
+
+ Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }.
+ Proof.
+ intros; unfold eq.
+ case (x ?= y); [ left | right | right ]; auto; discriminate.
+ Defined.
+
+End OrderedType_from_Alt.
+
+(** From the original presentation to this alternative one. *)
+
+Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt.
+ Import O.
+
+ Definition t := t.
+ Definition compare := compare.
+
+ Infix "?=" := compare (at level 70, no associativity).
+
+ Lemma compare_sym :
+   forall x y, (y?=x) = CompOpp (x?=y).
+ Proof.
+ intros x y; unfold compare.
+ generalize (compare_spec x y) (compare_spec y x); unfold Cmp, flip.
+ destruct (O.compare x y); destruct (O.compare y x); intros U V; auto.
+ rewrite U in V. elim (StrictOrder_Irreflexive y); auto.
+ rewrite U in V. elim (StrictOrder_Irreflexive y); auto.
+ rewrite V in U. elim (StrictOrder_Irreflexive x); auto.
+ rewrite V in U. elim (StrictOrder_Irreflexive x); auto.
+ rewrite V in U. elim (StrictOrder_Irreflexive x); auto.
+ rewrite V in U. elim (StrictOrder_Irreflexive y); auto.
+ Qed.
+
+ Lemma compare_Eq : forall x y, compare x y = Eq <-> eq x y.
+ Proof.
+ unfold compare.
+ intros x y; generalize (compare_spec x y).
+ destruct (O.compare x y); intuition; try discriminate.
+ rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto.
+ rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto.
+ Qed.
+
+ Lemma compare_Lt : forall x y, compare x y = Lt <-> lt x y.
+ Proof.
+ unfold compare.
+ intros x y; generalize (compare_spec x y); unfold Cmp, flip.
+ destruct (O.compare x y); intuition; try discriminate.
+ rewrite H in H0. elim (StrictOrder_Irreflexive y); auto.
+ rewrite H in H0. elim (StrictOrder_Irreflexive x); auto.
+ Qed.
+
+ Lemma compare_trans :
+   forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c.
+ Proof.
+ intros c x y z.
+ destruct c; unfold compare.
+ rewrite 3 compare_Eq; eauto.
+ rewrite 3 compare_Lt. apply StrictOrder_Transitive.
+ do 3 (rewrite compare_sym, CompOpp_iff, compare_Lt).
+ intros; apply StrictOrder_Transitive with y; auto.
+ Qed.
+
+End OrderedType_to_Alt.
diff --git a/theories/Structures/OrderedType2Ex.v b/theories/Structures/OrderedType2Ex.v
new file mode 100644
index 000000000..73bd3810f
--- /dev/null
+++ b/theories/Structures/OrderedType2Ex.v
@@ -0,0 +1,261 @@
+(***********************************************************************)
+(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
+(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
+(*   \VV/  *************************************************************)
+(*    //   *      This file is distributed under the terms of the      *)
+(*         *       GNU Lesser General Public License Version 2.1       *)
+(***********************************************************************)
+
+(* Finite sets library.
+ * Authors: Pierre Letouzey and Jean-Christophe Filliâtre
+ * Institution: LRI, CNRS UMR 8623 - Université Paris Sud
+ *              91405 Orsay, France *)
+
+(* $Id$ *)
+
+Require Import OrderedType2 DecidableType2Ex.
+Require Import ZArith NArith Ndec Compare_dec.
+
+(** * Examples of Ordered Type structures. *)
+
+(** First, a particular case of [OrderedType] where
+    the equality is the usual one of Coq. *)
+
+Module Type UsualOrderedType.
+ Include Type UsualDecidableType.
+
+ Parameter Inline lt : t -> t -> Prop.
+ Instance lt_strorder : StrictOrder lt.
+ (* The following is useless since eq is Leibniz, but should be there
+    for subtyping... *)
+ Instance lt_compat : Proper (eq==>eq==>iff) lt.
+
+ Parameter compare : t -> t -> comparison.
+ Axiom compare_spec : forall x y, Cmp eq lt (compare x y) x y.
+
+End UsualOrderedType.
+
+(** a [UsualOrderedType] is in particular an [OrderedType]. *)
+
+Module UOT_to_OT (U:UsualOrderedType) <: OrderedType := U.
+
+(** [nat] is an ordered type with respect to the usual order on natural numbers. *)
+
+Module Nat_as_OT <: UsualOrderedType.
+
+  Definition t := nat.
+  Definition eq := @eq nat.
+  Definition lt := lt.
+  Definition compare := nat_compare.
+  Definition eq_dec := eq_nat_dec.
+
+  Program Instance eq_equiv : Equivalence eq.
+
+  Instance lt_strorder : StrictOrder lt.
+  Proof.
+  constructor; [exact lt_irrefl|exact lt_trans].
+  Qed.
+
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+  Proof.
+  unfold eq in *; repeat red; intros; subst; auto.
+  Qed.
+
+  Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y.
+  Proof.
+  intros.
+  unfold Cmp, flip, lt, eq. destruct (compare x y) as [ ]_eqn:H.
+  apply nat_compare_eq; auto.
+  apply nat_compare_Lt_lt; auto.
+  apply nat_compare_Gt_gt; auto.
+  Qed.
+
+End Nat_as_OT.
+
+
+(** [Z] is an ordered type with respect to the usual order on integers. *)
+
+Module Z_as_OT <: UsualOrderedType.
+
+  Definition t := Z.
+  Definition eq := @eq Z.
+  Definition lt := Zlt.
+  Definition compare := Zcompare.
+  Definition eq_dec := Z_eq_dec.
+
+  Program Instance eq_equiv : Equivalence eq.
+
+  Instance lt_strorder : StrictOrder lt.
+  Proof.
+  constructor; [exact Zlt_irrefl | exact Zlt_trans].
+  Qed.
+
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+  Proof.
+  unfold eq in *; repeat red; intros; subst; auto.
+  Qed.
+
+  Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y.
+  Proof.
+  intros.
+  unfold Cmp, flip, lt, eq. destruct (compare x y) as [ ]_eqn:H.
+  apply Zcompare_Eq_eq; auto.
+  auto.
+  apply Zgt_lt; auto.
+  Qed.
+
+End Z_as_OT.
+
+(** [positive] is an ordered type with respect to the usual order
+    on natural numbers. *)
+
+Module Positive_as_OT <: UsualOrderedType.
+  Definition t:=positive.
+  Definition eq:=@eq positive.
+  Definition lt:=Plt.
+  Definition compare x y := Pcompare x y Eq.
+
+  Program Instance eq_equiv : Equivalence eq.
+
+  Instance lt_strorder : StrictOrder lt.
+  Proof.
+  constructor; [exact Plt_irrefl | exact Plt_trans].
+  Qed.
+
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+  Proof.
+  unfold eq in *; repeat red; intros; subst; auto.
+  Qed.
+
+  Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y.
+  Proof.
+  intros.
+  unfold Cmp, flip, lt, eq. destruct (compare x y) as [ ]_eqn:H.
+  apply Pcompare_Eq_eq; auto.
+  auto.
+  apply ZC1; auto.
+  Qed.
+
+  Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }.
+  Proof.
+   intros; unfold eq; decide equality.
+  Defined.
+
+End Positive_as_OT.
+
+
+(** [N] is an ordered type with respect to the usual order
+    on natural numbers. *)
+
+Module N_as_OT <: UsualOrderedType.
+  Definition t:=N.
+  Definition eq:=@eq N.
+  Definition lt:=Nlt.
+  Definition compare:=Ncompare.
+
+  Program Instance eq_equiv : Equivalence eq.
+
+  Instance lt_strorder : StrictOrder lt.
+  Proof.
+  constructor; [exact Nlt_irrefl | exact Nlt_trans].
+  Qed.
+
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+  Proof.
+  unfold eq in *; repeat red; intros; subst; auto.
+  Qed.
+
+  Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y.
+  Proof.
+  intros.
+  unfold Cmp, flip, lt, eq. destruct (compare x y) as [ ]_eqn:H.
+  apply Ncompare_Eq_eq; auto.
+  auto.
+  apply Ngt_Nlt; auto.
+  Qed.
+
+  Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }.
+  Proof.
+   intros. unfold eq. decide equality. apply Positive_as_OT.eq_dec.
+  Defined.
+
+End N_as_OT.
+
+
+(** An OrderedType can now directly be seen as a DecidableType *)
+
+Module OT_as_DT (O:OrderedType) <: DecidableType := O.
+
+(** (Usual) Decidable Type for [nat], [positive], [N], [Z] *)
+
+Module Nat_as_DT <: UsualDecidableType := Nat_as_OT.
+Module Positive_as_DT <: UsualDecidableType := Positive_as_OT.
+Module N_as_DT <: UsualDecidableType := N_as_OT.
+Module Z_as_DT <: UsualDecidableType := Z_as_OT.
+
+
+
+
+(** From two ordered types, we can build a new OrderedType
+   over their cartesian product, using the lexicographic order. *)
+
+Module PairOrderedType(O1 O2:OrderedType) <: OrderedType.
+
+ Definition t := prod O1.t O2.t.
+
+ Definition eq := ProdRel O1.eq O2.eq.
+
+ Definition lt x y :=
+    O1.lt (fst x) (fst y) \/
+    (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)).
+
+ Instance eq_equiv : Equivalence eq.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+ split.
+ (* irreflexive *)
+ intros (x1,x2); compute. destruct 1.
+ apply (StrictOrder_Irreflexive x1); auto.
+ apply (StrictOrder_Irreflexive x2); intuition.
+ (* transitive *)
+ intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition.
+ left; etransitivity; eauto.
+ left; rewrite <- H0; auto.
+ left; rewrite H; auto.
+ right; split; eauto. etransitivity; eauto.
+ Qed.
+
+ Instance lt_compat : Proper (eq==>eq==>iff) lt.
+ Proof.
+ intros (x1,x2) (x1',x2') (X1,X2) (y1,y2) (y1',y2') (Y1,Y2).
+ unfold lt; simpl in *.
+ rewrite X1,X2,Y1,Y2; intuition.
+ Qed.
+
+ Definition compare x y :=
+  match O1.compare (fst x) (fst y) with
+   | Eq => O2.compare (snd x) (snd y)
+   | Lt => Lt
+   | Gt => Gt
+  end.
+
+ Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y.
+ Proof.
+ intros (x1,x2) (y1,y2); unfold Cmp, flip, compare, eq, lt; simpl.
+ generalize (O1.compare_spec x1 y1); destruct (O1.compare x1 y1); intros; auto.
+ generalize (O2.compare_spec x2 y2); destruct (O2.compare x2 y2); intros; auto.
+ Qed.
+
+ Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}.
+ Proof.
+ intros; generalize (compare_spec x y); destruct (compare x y).
+ left; auto.
+ right. intros E; rewrite E in *.
+  apply (StrictOrder_Irreflexive y); auto.
+ right. intros E; rewrite E in *.
+  apply (StrictOrder_Irreflexive y); auto.
+ Defined.
+
+End PairOrderedType.
+
diff --git a/theories/FSets/OrderedTypeAlt.v b/theories/Structures/OrderedTypeAlt.v
index 23ae4c85a..23ae4c85a 100644
--- a/theories/FSets/OrderedTypeAlt.v
+++ b/theories/Structures/OrderedTypeAlt.v
diff --git a/theories/FSets/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v
index a39f336a5..a39f336a5 100644
--- a/theories/FSets/OrderedTypeEx.v
+++ b/theories/Structures/OrderedTypeEx.v
diff --git a/theories/theories.itarget b/theories/theories.itarget
index fc7a1eca3..320d6d41c 100644
--- a/theories/theories.itarget
+++ b/theories/theories.itarget
@@ -61,9 +61,29 @@ FSets/FSetProperties.vo
 FSets/FSets.vo
 FSets/FSetToFiniteSet.vo
 FSets/FSetWeakList.vo
-FSets/OrderedTypeAlt.vo
-FSets/OrderedTypeEx.vo
-FSets/OrderedType.vo
+
+MSets/MSetAVL.vo
+MSets/MSetDecide.vo
+MSets/MSetEqProperties.vo
+MSets/MSetFacts.vo
+MSets/MSetInterface.vo
+MSets/MSetList.vo
+MSets/MSetProperties.vo
+MSets/MSets.vo
+MSets/MSetToFiniteSet.vo
+MSets/MSetWeakList.vo
+
+Structures/OrderedTypeAlt.vo
+Structures/OrderedTypeEx.vo
+Structures/OrderedType.vo
+Structures/DecidableType.vo
+Structures/DecidableTypeEx.vo
+
+Structures/OrderedType2Alt.vo
+Structures/OrderedType2Ex.vo
+Structures/OrderedType2.vo
+Structures/DecidableType2.vo
+Structures/DecidableType2Ex.vo
 
 Init/Datatypes.vo
 Init/Logic_Type.vo
@@ -79,6 +99,7 @@ Lists/ListSet.vo
 Lists/ListTactics.vo
 Lists/List.vo
 Lists/SetoidList.vo
+Lists/SetoidList2.vo
 Lists/StreamMemo.vo
 Lists/Streams.vo
 Lists/TheoryList.vo
@@ -96,8 +117,6 @@ Logic/Classical_Type.vo
 Logic/ClassicalUniqueChoice.vo
 Logic/Classical.vo
 Logic/ConstructiveEpsilon.vo
-Logic/DecidableTypeEx.vo
-Logic/DecidableType.vo
 Logic/Decidable.vo
 Logic/Description.vo
 Logic/Diaconescu.vo
diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml
index 4007a96bb..d9fcdb247 100644
--- a/toplevel/coqinit.ml
+++ b/toplevel/coqinit.ml
@@ -66,12 +66,14 @@ let theories_dirs_map = [
     "theories/Unicode", "Unicode" ;
     "theories/Classes", "Classes" ;
     "theories/Program", "Program" ;
+    "theories/MSets", "MSets" ;
     "theories/FSets", "FSets" ;
     "theories/Reals", "Reals" ;
     "theories/Strings", "Strings" ;
     "theories/Sorting", "Sorting" ;
     "theories/Setoids", "Setoids" ;
     "theories/Sets", "Sets" ;
+    "theories/Structures", "Structures" ;
     "theories/Lists", "Lists" ;
     "theories/Wellfounded", "Wellfounded" ;
     "theories/Relations", "Relations" ;