21 files changed, 15731 insertions, 0 deletions

diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v
new file mode 100644
index 0000000000..63f907e567
--- /dev/null
+++ b/theories/FSets/FMapAVL.v
@@ -0,0 +1,2201 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(* Finite map library.  *)
+
+(** * FMapAVL *)
+
+(** This module implements maps using AVL trees.
+    It follows the implementation from Ocaml's standard library.
+
+    See the comments at the beginning of FSetAVL for more details.
+*)
+
+Require Import FunInd FMapInterface FMapList ZArith Int.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** Notations and helper lemma about pairs *)
+
+Declare Scope pair_scope.
+Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
+Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
+
+(** * The Raw functor
+
+   Functor of pure functions + separate proofs of invariant
+   preservation *)
+
+Module Raw (Import I:Int)(X: OrderedType).
+Local Open Scope pair_scope.
+Local Open Scope lazy_bool_scope.
+Local Open Scope Int_scope.
+Local Notation int := I.t.
+
+Definition key := X.t.
+Hint Transparent key : core.
+
+(** * Trees *)
+
+Section Elt.
+
+Variable elt : Type.
+
+(** * Trees
+
+   The fifth field of [Node] is the height of the tree *)
+
+#[universes(template)]
+Inductive tree :=
+  | Leaf : tree
+  | Node : tree -> key -> elt -> tree -> int -> tree.
+
+Notation t := tree.
+
+(** * Basic functions on trees: height and cardinal *)
+
+Definition height (m : t) : int :=
+  match m with
+  | Leaf => 0
+  | Node _ _ _ _ h => h
+  end.
+
+Fixpoint cardinal (m : t) : nat :=
+  match m with
+   | Leaf => 0%nat
+   | Node l _ _ r _ => S (cardinal l + cardinal r)
+  end.
+
+(** * Empty Map *)
+
+Definition empty := Leaf.
+
+(** * Emptyness test *)
+
+Definition is_empty m := match m with Leaf => true | _ => false end.
+
+(** * Membership *)
+
+(** The [mem] function is deciding membership. It exploits the [bst] property
+    to achieve logarithmic complexity. *)
+
+Fixpoint mem x m : bool :=
+   match m with
+     |  Leaf => false
+     |  Node l y _ r _ => match X.compare x y with
+             | LT _ => mem x l
+             | EQ _ => true
+             | GT _ => mem x r
+         end
+   end.
+
+Fixpoint find x m : option elt :=
+   match m with
+     |  Leaf => None
+     |  Node l y d r _ => match X.compare x y with
+             | LT _ => find x l
+             | EQ _ => Some d
+             | GT _ => find x r
+         end
+   end.
+
+(** * Helper functions *)
+
+(** [create l x r] creates a node, assuming [l] and [r]
+    to be balanced and [|height l - height r| <= 2]. *)
+
+Definition create l x e r :=
+   Node l x e r (max (height l) (height r) + 1).
+
+(** [bal l x e r] acts as [create], but performs one step of
+    rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *)
+
+Definition assert_false := create.
+
+Fixpoint bal l x d r :=
+  let hl := height l in
+  let hr := height r in
+  if gt_le_dec hl (hr+2) then
+    match l with
+     | Leaf => assert_false l x d r
+     | Node ll lx ld lr _ =>
+       if ge_lt_dec (height ll) (height lr) then
+         create ll lx ld (create lr x d r)
+       else
+         match lr with
+          | Leaf => assert_false l x d r
+          | Node lrl lrx lrd lrr _ =>
+              create (create ll lx ld lrl) lrx lrd (create lrr x d r)
+         end
+    end
+  else
+    if gt_le_dec hr (hl+2) then
+      match r with
+       | Leaf => assert_false l x d r
+       | Node rl rx rd rr _ =>
+         if ge_lt_dec (height rr) (height rl) then
+            create (create l x d rl) rx rd rr
+         else
+           match rl with
+            | Leaf => assert_false l x d r
+            | Node rll rlx rld rlr _ =>
+                create (create l x d rll) rlx rld (create rlr rx rd rr)
+           end
+      end
+    else
+      create l x d r.
+
+(** * Insertion *)
+
+Fixpoint add x d m :=
+  match m with
+   | Leaf => Node Leaf x d Leaf 1
+   | Node l y d' r h =>
+      match X.compare x y with
+         | LT _ => bal (add x d l) y d' r
+         | EQ _ => Node l y d r h
+         | GT _ => bal l y d' (add x d r)
+      end
+  end.
+
+(** * Extraction of minimum binding
+
+  Morally, [remove_min] is to be applied to a non-empty tree
+  [t = Node l x e r h]. Since we can't deal here with [assert false]
+  for [t=Leaf], we pre-unpack [t] (and forget about [h]).
+*)
+
+Fixpoint remove_min l x d r : t*(key*elt) :=
+  match l with
+    | Leaf => (r,(x,d))
+    | Node ll lx ld lr lh =>
+       let (l',m) := remove_min ll lx ld lr in
+       (bal l' x d r, m)
+  end.
+
+(** * Merging two trees
+
+  [merge t1 t2] builds the union of [t1] and [t2] assuming all elements
+  of [t1] to be smaller than all elements of [t2], and
+  [|height t1 - height t2| <= 2].
+*)
+
+Fixpoint merge s1 s2 :=  match s1,s2 with
+  | Leaf, _ => s2
+  | _, Leaf => s1
+  | _, Node l2 x2 d2 r2 h2 =>
+    match remove_min l2 x2 d2 r2 with
+      (s2',(x,d)) => bal s1 x d s2'
+    end
+end.
+
+(** * Deletion *)
+
+Fixpoint remove x m := match m with
+  | Leaf => Leaf
+  | Node l y d r h =>
+      match X.compare x y with
+         | LT _ => bal (remove x l) y d r
+         | EQ _ => merge l r
+         | GT _ => bal l y d (remove x r)
+      end
+   end.
+
+(** * join
+
+    Same as [bal] but does not assume anything regarding heights of [l]
+    and [r].
+*)
+
+Fixpoint join l : key -> elt -> t -> t :=
+  match l with
+    | Leaf => add
+    | Node ll lx ld lr lh => fun x d =>
+       fix join_aux (r:t) : t := match r with
+          | Leaf =>  add x d l
+          | Node rl rx rd rr rh =>
+               if gt_le_dec lh (rh+2) then bal ll lx ld (join lr x d r)
+               else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr
+               else create l x d r
+          end
+  end.
+
+(** * Splitting
+
+    [split x m] returns a triple [(l, o, r)] where
+    - [l] is the set of elements of [m] that are [< x]
+    - [r] is the set of elements of [m] that are [> x]
+    - [o] is the result of [find x m].
+*)
+
+#[universes(template)]
+Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }.
+Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).
+
+Fixpoint split x m : triple := match m with
+  | Leaf => << Leaf, None, Leaf >>
+  | Node l y d r h =>
+     match X.compare x y with
+      | LT _ => let (ll,o,rl) := split x l in << ll, o, join rl y d r >>
+      | EQ _ => << l, Some d, r >>
+      | GT _ => let (rl,o,rr) := split x r in << join l y d rl, o, rr >>
+     end
+ end.
+
+(** * Concatenation
+
+   Same as [merge] but does not assume anything about heights.
+*)
+
+Definition concat m1 m2 :=
+   match m1, m2 with
+      | Leaf, _ => m2
+      | _ , Leaf => m1
+      | _, Node l2 x2 d2 r2 _ =>
+            let (m2',xd) := remove_min l2 x2 d2 r2 in
+            join m1 xd#1 xd#2 m2'
+   end.
+
+(** * Elements *)
+
+(** [elements_tree_aux acc t] catenates the elements of [t] in infix
+    order to the list [acc] *)
+
+Fixpoint elements_aux (acc : list (key*elt)) m : list (key*elt) :=
+  match m with
+   | Leaf => acc
+   | Node l x d r _ => elements_aux ((x,d) :: elements_aux acc r) l
+  end.
+
+(** then [elements] is an instantiation with an empty [acc] *)
+
+Definition elements := elements_aux nil.
+
+(** * Fold *)
+
+Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A :=
+ fun a => match m with
+  | Leaf => a
+  | Node l x d r _ => fold f r (f x d (fold f l a))
+ end.
+
+(** * Comparison *)
+
+Variable cmp : elt->elt->bool.
+
+(** ** Enumeration of the elements of a tree *)
+
+#[universes(template)]
+Inductive enumeration :=
+ | End : enumeration
+ | More : key -> elt -> t -> enumeration -> enumeration.
+
+(** [cons m e] adds the elements of tree [m] on the head of
+    enumeration [e]. *)
+
+Fixpoint cons m e : enumeration :=
+ match m with
+  | Leaf => e
+  | Node l x d r h => cons l (More x d r e)
+ end.
+
+(** One step of comparison of elements *)
+
+Definition equal_more x1 d1 (cont:enumeration->bool) e2 :=
+ match e2 with
+ | End => false
+ | More x2 d2 r2 e2 =>
+     match X.compare x1 x2 with
+      | EQ _ => cmp d1 d2 &&& cont (cons r2 e2)
+      | _ => false
+     end
+ end.
+
+(** Comparison of left tree, middle element, then right tree *)
+
+Fixpoint equal_cont m1 (cont:enumeration->bool) e2 :=
+ match m1 with
+  | Leaf => cont e2
+  | Node l1 x1 d1 r1 _ =>
+     equal_cont l1 (equal_more x1 d1 (equal_cont r1 cont)) e2
+  end.
+
+(** Initial continuation *)
+
+Definition equal_end e2 := match e2 with End => true | _ => false end.
+
+(** The complete comparison *)
+
+Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End).
+
+End Elt.
+Notation t := tree.
+Notation "<< l , b , r >>" := (mktriple l b r) (at level 9).
+Notation "t #l" := (t_left t) (at level 9, format "t '#l'").
+Notation "t #o" := (t_opt t) (at level 9, format "t '#o'").
+Notation "t #r" := (t_right t) (at level 9, format "t '#r'").
+
+
+(** * Map *)
+
+Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' :=
+  match m with
+   | Leaf _   => Leaf _
+   | Node l x d r h => Node (map f l) x (f d) (map f r) h
+  end.
+
+(* * Mapi *)
+
+Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' :=
+  match m with
+   | Leaf _ => Leaf _
+   | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h
+  end.
+
+(** * Map with removal *)
+
+Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt)
+  : t elt' :=
+  match m with
+   | Leaf _ => Leaf _
+   | Node l x d r h =>
+      match f x d with
+       | Some d' => join (map_option f l) x d' (map_option f r)
+       | None => concat (map_option f l) (map_option f r)
+      end
+  end.
+
+(** * Optimized map2
+
+  Suggestion by B. Gregoire: a [map2] function with specialized
+  arguments that allows bypassing some tree traversal. Instead of one
+  [f0] of type [key -> option elt -> option elt' -> option elt''],
+  we ask here for:
+  - [f] which is a specialisation of [f0] when first option isn't [None]
+  - [mapl] treats a [tree elt] with [f0] when second option is [None]
+  - [mapr] treats a [tree elt'] with [f0] when first option is [None]
+
+  The idea is that [mapl] and [mapr] can be instantaneous (e.g.
+  the identity or some constant function).
+*)
+
+Section Map2_opt.
+Variable elt elt' elt'' : Type.
+Variable f : key -> elt -> option elt' -> option elt''.
+Variable mapl : t elt -> t elt''.
+Variable mapr : t elt' -> t elt''.
+
+Fixpoint map2_opt m1 m2 :=
+ match m1, m2 with
+  | Leaf _, _ => mapr m2
+  | _, Leaf _ => mapl m1
+  | Node l1 x1 d1 r1 h1, _ =>
+     let (l2',o2,r2') := split x1 m2 in
+     match f x1 d1 o2 with
+      | Some e => join (map2_opt l1 l2') x1 e (map2_opt r1 r2')
+      | None => concat (map2_opt l1 l2') (map2_opt r1 r2')
+     end
+ end.
+
+End Map2_opt.
+
+(** * Map2
+
+    The [map2] function of the Map interface can be implemented
+    via [map2_opt] and [map_option].
+*)
+
+Section Map2.
+Variable elt elt' elt'' : Type.
+Variable f : option elt -> option elt' -> option elt''.
+
+Definition map2 : t elt -> t elt' -> t elt'' :=
+ map2_opt
+   (fun _ d o => f (Some d) o)
+   (map_option (fun _ d => f (Some d) None))
+   (map_option (fun _ d' => f None (Some d'))).
+
+End Map2.
+
+
+
+(** * Invariants *)
+
+Section Invariants.
+Variable elt : Type.
+
+(** ** Occurrence in a tree *)
+
+Inductive MapsTo (x : key)(e : elt) : t elt -> Prop :=
+  | MapsRoot : forall l r h y,
+      X.eq x y -> MapsTo x e (Node l y e r h)
+  | MapsLeft : forall l r h y e',
+      MapsTo x e l -> MapsTo x e (Node l y e' r h)
+  | MapsRight : forall l r h y e',
+      MapsTo x e r -> MapsTo x e (Node l y e' r h).
+
+Inductive In (x : key) : t elt -> Prop :=
+  | InRoot : forall l r h y e,
+      X.eq x y -> In x (Node l y e r h)
+  | InLeft : forall l r h y e',
+      In x l -> In x (Node l y e' r h)
+  | InRight : forall l r h y e',
+      In x r -> In x (Node l y e' r h).
+
+Definition In0 k m := exists e:elt, MapsTo k e m.
+
+(** ** Binary search trees *)
+
+(** [lt_tree x s]: all elements in [s] are smaller than [x]
+   (resp. greater for [gt_tree]) *)
+
+Definition lt_tree x m := forall y, In y m -> X.lt y x.
+Definition gt_tree x m := forall y, In y m -> X.lt x y.
+
+(** [bst t] : [t] is a binary search tree *)
+
+Inductive bst : t elt -> Prop :=
+  | BSLeaf : bst (Leaf _)
+  | BSNode : forall x e l r h, bst l -> bst r ->
+     lt_tree x l -> gt_tree x r -> bst (Node l x e r h).
+
+End Invariants.
+
+
+(** * Correctness proofs, isolated in a sub-module *)
+
+Module Proofs.
+ Module MX := OrderedTypeFacts X.
+ Module PX := KeyOrderedType X.
+ Module L := FMapList.Raw X.
+
+Functional Scheme mem_ind := Induction for mem Sort Prop.
+Functional Scheme find_ind := Induction for find Sort Prop.
+Functional Scheme bal_ind := Induction for bal Sort Prop.
+Functional Scheme add_ind := Induction for add Sort Prop.
+Functional Scheme remove_min_ind := Induction for remove_min Sort Prop.
+Functional Scheme merge_ind := Induction for merge Sort Prop.
+Functional Scheme remove_ind := Induction for remove Sort Prop.
+Functional Scheme concat_ind := Induction for concat Sort Prop.
+Functional Scheme split_ind := Induction for split Sort Prop.
+Functional Scheme map_option_ind := Induction for map_option Sort Prop.
+Functional Scheme map2_opt_ind := Induction for map2_opt Sort Prop.
+
+(** * Automation and dedicated tactics. *)
+
+Hint Constructors tree MapsTo In bst : core.
+Hint Unfold lt_tree gt_tree : core.
+
+Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h)
+ "as" ident(s) :=
+ set (s:=Node l x d r h) in *; clearbody s; clear l x d r h.
+
+(** A tactic for cleaning hypothesis after use of functional induction. *)
+
+Ltac clearf :=
+ match goal with
+  | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf
+  | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf
+  | _ => idtac
+ end.
+
+(** A tactic to repeat [inversion_clear] on all hyps of the
+    form [(f (Node ...))] *)
+
+Ltac inv f :=
+  match goal with
+     | H:f (Leaf _) |- _ => inversion_clear H; inv f
+     | H:f _ (Leaf _) |- _ => inversion_clear H; inv f
+     | H:f _ _ (Leaf _) |- _ => inversion_clear H; inv f
+     | H:f _ _ _ (Leaf _) |- _ => inversion_clear H; inv f
+     | H:f (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+     | H:f _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+     | H:f _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+     | H:f _ _ _ (Node _ _ _ _ _) |- _ => inversion_clear H; inv f
+     | _ => idtac
+  end.
+
+Ltac inv_all f :=
+  match goal with
+   | H: f _ |- _ => inversion_clear H; inv f
+   | H: f _ _ |- _ => inversion_clear H; inv f
+   | H: f _ _ _ |- _ => inversion_clear H; inv f
+   | H: f _ _ _ _ |- _ => inversion_clear H; inv f
+   | _ => idtac
+  end.
+
+(** Helper tactic concerning order of elements. *)
+
+Ltac order := match goal with
+ | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order
+ | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order
+ | _ => MX.order
+end.
+
+Ltac intuition_in := repeat (intuition; inv In; inv MapsTo).
+
+(* Function/Functional Scheme can't deal with internal fix.
+   Let's do its job by hand: *)
+
+Ltac join_tac :=
+ intros l; induction l as [| ll _ lx ld lr Hlr lh];
+   [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join;
+     [ | destruct (gt_le_dec lh (rh+2)) as [GT|LE];
+       [ match goal with |- context [ bal ?u ?v ?w ?z ] =>
+           replace (bal u v w z)
+           with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto]
+         end
+       | destruct (gt_le_dec rh (lh+2)) as [GT'|LE'];
+         [ match goal with |- context [ bal ?u ?v ?w ?z ] =>
+             replace (bal u v w z)
+             with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto]
+           end
+         | ] ] ] ]; intros.
+
+Section Elt.
+Variable elt:Type.
+Implicit Types m r : t elt.
+
+(** * Basic results about [MapsTo], [In], [lt_tree], [gt_tree], [height] *)
+
+(** Facts about [MapsTo] and [In]. *)
+
+Lemma MapsTo_In : forall k e m, MapsTo k e m -> In k m.
+Proof.
+ induction 1; auto.
+Qed.
+Hint Resolve MapsTo_In : core.
+
+Lemma In_MapsTo : forall k m, In k m -> exists e, MapsTo k e m.
+Proof.
+ induction 1; try destruct IHIn as (e,He); exists e; auto.
+Qed.
+
+Lemma In_alt : forall k m, In0 k m <-> In k m.
+Proof.
+ split.
+ intros (e,H); eauto.
+ unfold In0; apply In_MapsTo; auto.
+Qed.
+
+Lemma MapsTo_1 :
+ forall m x y e, X.eq x y -> MapsTo x e m -> MapsTo y e m.
+Proof.
+ induction m; simpl; intuition_in; eauto.
+Qed.
+Hint Immediate MapsTo_1 : core.
+
+Lemma In_1 :
+ forall m x y, X.eq x y -> In x m -> In y m.
+Proof.
+ intros m x y; induction m; simpl; intuition_in; eauto.
+Qed.
+
+Lemma In_node_iff :
+ forall l x e r h y,
+  In y (Node l x e r h) <-> In y l \/ X.eq y x \/ In y r.
+Proof.
+ intuition_in.
+Qed.
+
+(** Results about [lt_tree] and [gt_tree] *)
+
+Lemma lt_leaf : forall x, lt_tree x (Leaf elt).
+Proof.
+ unfold lt_tree; intros; intuition_in.
+Qed.
+
+Lemma gt_leaf : forall x, gt_tree x (Leaf elt).
+Proof.
+  unfold gt_tree; intros; intuition_in.
+Qed.
+
+Lemma lt_tree_node : forall x y l r e h,
+ lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y e r h).
+Proof.
+ unfold lt_tree in *; intuition_in; order.
+Qed.
+
+Lemma gt_tree_node : forall x y l r e h,
+ gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y e r h).
+Proof.
+ unfold gt_tree in *; intuition_in; order.
+Qed.
+
+Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core.
+
+Lemma lt_left : forall x y l r e h,
+ lt_tree x (Node l y e r h) -> lt_tree x l.
+Proof.
+ intuition_in.
+Qed.
+
+Lemma lt_right : forall x y l r e h,
+ lt_tree x (Node l y e r h) -> lt_tree x r.
+Proof.
+ intuition_in.
+Qed.
+
+Lemma gt_left : forall x y l r e h,
+ gt_tree x (Node l y e r h) -> gt_tree x l.
+Proof.
+ intuition_in.
+Qed.
+
+Lemma gt_right : forall x y l r e h,
+ gt_tree x (Node l y e r h) -> gt_tree x r.
+Proof.
+ intuition_in.
+Qed.
+
+Hint Resolve lt_left lt_right gt_left gt_right : core.
+
+Lemma lt_tree_not_in :
+ forall x m, lt_tree x m -> ~ In x m.
+Proof.
+ intros; intro; generalize (H _ H0); order.
+Qed.
+
+Lemma lt_tree_trans :
+ forall x y, X.lt x y -> forall m, lt_tree x m -> lt_tree y m.
+Proof.
+ eauto.
+Qed.
+
+Lemma gt_tree_not_in :
+ forall x m, gt_tree x m -> ~ In x m.
+Proof.
+ intros; intro; generalize (H _ H0); order.
+Qed.
+
+Lemma gt_tree_trans :
+ forall x y, X.lt y x -> forall m, gt_tree x m -> gt_tree y m.
+Proof.
+ eauto.
+Qed.
+
+Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core.
+
+(** * Empty map *)
+
+Definition Empty m := forall (a:key)(e:elt) , ~ MapsTo a e m.
+
+Lemma empty_bst : bst (empty elt).
+Proof.
+ unfold empty; auto.
+Qed.
+
+Lemma empty_1 : Empty (empty elt).
+Proof.
+ unfold empty, Empty; intuition_in.
+Qed.
+
+(** * Emptyness test *)
+
+Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
+Proof.
+ destruct m as [|r x e l h]; simpl; auto.
+ intro H; elim (H x e); auto.
+Qed.
+
+Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+Proof.
+ destruct m; simpl; intros; try discriminate; red; intuition_in.
+Qed.
+
+(** * Membership *)
+
+Lemma mem_1 : forall m x, bst m -> In x m -> mem x m = true.
+Proof.
+ intros m x; functional induction (mem x m); auto; intros; clearf;
+  inv bst; intuition_in; order.
+Qed.
+
+Lemma mem_2 : forall m x, mem x m = true -> In x m.
+Proof.
+ intros m x; functional induction (mem x m); auto; intros; discriminate.
+Qed.
+
+Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e.
+Proof.
+ intros m x; functional induction (find x m); auto; intros; clearf;
+  inv bst; intuition_in; simpl; auto;
+ try solve [order | absurd (X.lt x y); eauto | absurd (X.lt y x); eauto].
+Qed.
+
+Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+Proof.
+ intros m x; functional induction (find x m); subst; intros; clearf;
+  try discriminate.
+ constructor 2; auto.
+ inversion H; auto.
+ constructor 3; auto.
+Qed.
+
+Lemma find_iff : forall m x e, bst m ->
+ (find x m = Some e <-> MapsTo x e m).
+Proof.
+ split; auto using find_1, find_2.
+Qed.
+
+Lemma find_in : forall m x, find x m <> None -> In x m.
+Proof.
+ intros.
+ case_eq (find x m); [intros|congruence].
+ apply MapsTo_In with e; apply find_2; auto.
+Qed.
+
+Lemma in_find : forall m x, bst m -> In x m -> find x m <> None.
+Proof.
+ intros.
+ destruct (In_MapsTo H0) as (d,Hd).
+ rewrite (find_1 H Hd); discriminate.
+Qed.
+
+Lemma find_in_iff : forall m x, bst m ->
+ (find x m <> None <-> In x m).
+Proof.
+ split; auto using find_in, in_find.
+Qed.
+
+Lemma not_find_iff : forall m x, bst m ->
+ (find x m = None <-> ~In x m).
+Proof.
+ split; intros.
+ red; intros.
+ elim (in_find H H1 H0).
+ case_eq (find x m); [ intros | auto ].
+ elim H0; apply find_in; congruence.
+Qed.
+
+Lemma find_find : forall m m' x,
+ find x m = find x m' <->
+ (forall d, find x m = Some d <-> find x m' = Some d).
+Proof.
+ intros; destruct (find x m); destruct (find x m'); split; intros;
+  try split; try congruence.
+ rewrite H; auto.
+ symmetry; rewrite <- H; auto.
+ rewrite H; auto.
+Qed.
+
+Lemma find_mapsto_equiv : forall m m' x, bst m -> bst m' ->
+ (find x m = find x m' <->
+  (forall d, MapsTo x d m <-> MapsTo x d m')).
+Proof.
+ intros m m' x Hm Hm'.
+ rewrite find_find.
+ split; intros H d; specialize H with d.
+ rewrite <- 2 find_iff; auto.
+ rewrite 2 find_iff; auto.
+Qed.
+
+Lemma find_in_equiv : forall m m' x, bst m -> bst m' ->
+ find x m = find x m' ->
+ (In x m <-> In x m').
+Proof.
+ split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ];
+  apply in_find; auto.
+Qed.
+
+(** * Helper functions *)
+
+Lemma create_bst :
+ forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r ->
+ bst (create l x e r).
+Proof.
+ unfold create; auto.
+Qed.
+Hint Resolve create_bst : core.
+
+Lemma create_in :
+ forall l x e r y,
+  In y (create l x e r) <-> X.eq y x \/ In y l \/ In y r.
+Proof.
+ unfold create; split; [ inversion_clear 1 | ]; intuition.
+Qed.
+
+Lemma bal_bst : forall l x e r, bst l -> bst r ->
+ lt_tree x l -> gt_tree x r -> bst (bal l x e r).
+Proof.
+ intros l x e r; functional induction (bal l x e r); intros; clearf;
+ inv bst; repeat apply create_bst; auto; unfold create; try constructor;
+ (apply lt_tree_node || apply gt_tree_node); auto;
+ (eapply lt_tree_trans || eapply gt_tree_trans); eauto. 
+Qed.
+Hint Resolve bal_bst : core.
+
+Lemma bal_in : forall l x e r y,
+ In y (bal l x e r) <-> X.eq y x \/ In y l \/ In y r.
+Proof.
+ intros l x e r; functional induction (bal l x e r); intros; clearf;
+ rewrite !create_in; intuition_in.
+Qed.
+
+Lemma bal_mapsto : forall l x e r y e',
+ MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r).
+Proof.
+ intros l x e r; functional induction (bal l x e r); intros; clearf;
+ unfold assert_false, create; intuition_in.
+Qed.
+
+Lemma bal_find : forall l x e r y,
+ bst l -> bst r -> lt_tree x l -> gt_tree x r ->
+ find y (bal l x e r) = find y (create l x e r).
+Proof.
+ intros; rewrite find_mapsto_equiv; auto; intros; apply bal_mapsto.
+Qed.
+
+(** * Insertion *)
+
+Lemma add_in : forall m x y e,
+ In y (add x e m) <-> X.eq y x \/ In y m.
+Proof.
+ intros m x y e; functional induction (add x e m); auto; intros;
+ try (rewrite bal_in, IHt); intuition_in.
+ apply In_1 with x; auto.
+Qed.
+
+Lemma add_bst : forall m x e, bst m -> bst (add x e m).
+Proof.
+ intros m x e; functional induction (add x e m); intros;
+  inv bst; try apply bal_bst; auto;
+  intro z; rewrite add_in; intuition.
+ apply MX.eq_lt with x; auto.
+ apply MX.lt_eq with x; auto.
+Qed.
+Hint Resolve add_bst : core.
+
+Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m).
+Proof.
+ intros m x y e; functional induction (add x e m);
+   intros; inv bst; try rewrite bal_mapsto; unfold create; eauto.
+Qed.
+
+Lemma add_2 : forall m x y e e', ~X.eq x y ->
+ MapsTo y e m -> MapsTo y e (add x e' m).
+Proof.
+ intros m x y e e'; induction m; simpl; auto.
+ destruct (X.compare x k);
+ intros; inv bst; try rewrite bal_mapsto; unfold create; auto;
+   inv MapsTo; auto; order.
+Qed.
+
+Lemma add_3 : forall m x y e e', ~X.eq x y ->
+ MapsTo y e (add x e' m) -> MapsTo y e m.
+Proof.
+ intros m x y e e'; induction m; simpl; auto.
+ intros; inv MapsTo; auto; order.
+ destruct (X.compare x k); intro;
+  try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto;
+  order.
+Qed.
+
+Lemma add_find : forall m x y e, bst m ->
+ find y (add x e m) =
+  match X.compare y x with EQ _ => Some e | _ => find y m end.
+Proof.
+ intros.
+ assert (~X.eq x y -> find y (add x e m) = find y m).
+  intros; rewrite find_mapsto_equiv; auto.
+  split; eauto using add_2, add_3.
+ destruct X.compare; try (apply H0; order).
+ auto using find_1, add_1.
+Qed.
+
+(** * Extraction of minimum binding *)
+
+Lemma remove_min_in : forall l x e r h y,
+ In y (Node l x e r h) <->
+  X.eq y (remove_min l x e r)#2#1 \/ In y (remove_min l x e r)#1.
+Proof.
+ intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ intuition_in.
+ rewrite e0 in *; simpl; intros.
+ rewrite bal_in, In_node_iff, IHp; intuition.
+Qed.
+
+Lemma remove_min_mapsto : forall l x e r h y e',
+  MapsTo y e' (Node l x e r h) <->
+   ((X.eq y (remove_min l x e r)#2#1) /\ e' = (remove_min l x e r)#2#2)
+    \/ MapsTo y e' (remove_min l x e r)#1.
+Proof.
+ intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ intuition_in; subst; auto.
+ rewrite e0 in *; simpl; intros.
+ rewrite bal_mapsto; auto; unfold create.
+ simpl in *;destruct (IHp _x y e').
+ intuition.
+ inversion_clear H1; intuition.
+ inversion_clear H3; intuition.
+Qed.
+
+Lemma remove_min_bst : forall l x e r h,
+ bst (Node l x e r h) -> bst (remove_min l x e r)#1.
+Proof.
+ intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ inv bst; auto.
+ inversion_clear H; inversion_clear H0.
+ apply bal_bst; auto.
+ rewrite e0 in *; simpl in *; apply (IHp _x); auto.
+ intro; intros.
+ generalize (remove_min_in ll lx ld lr _x y).
+ rewrite e0; simpl in *.
+ destruct 1.
+ apply H2; intuition.
+Qed.
+Hint Resolve remove_min_bst : core.
+
+Lemma remove_min_gt_tree : forall l x e r h,
+ bst (Node l x e r h) ->
+ gt_tree (remove_min l x e r)#2#1 (remove_min l x e r)#1.
+Proof.
+ intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ inv bst; auto.
+ inversion_clear H.
+ intro; intro.
+ rewrite e0 in *;simpl in *.
+ generalize (IHp _x H0).
+ generalize (remove_min_in ll lx ld lr _x m#1).
+ rewrite e0; simpl; intros.
+ rewrite (bal_in l' x d r y) in H.
+ assert (In m#1 (Node ll lx ld lr _x)) by (rewrite H4; auto); clear H4.
+ assert (X.lt m#1 x) by order.
+ decompose [or] H; order.
+Qed.
+Hint Resolve remove_min_gt_tree : core.
+
+Lemma remove_min_find : forall l x e r h y,
+ bst (Node l x e r h) ->
+ find y (Node l x e r h) =
+   match X.compare y (remove_min l x e r)#2#1 with
+    | LT _ => None
+    | EQ _ => Some (remove_min l x e r)#2#2
+    | GT _ => find y (remove_min l x e r)#1
+   end.
+Proof.
+ intros.
+ destruct X.compare.
+ rewrite not_find_iff; auto.
+ rewrite remove_min_in; red; destruct 1 as [H'|H']; [ order | ].
+ generalize (remove_min_gt_tree H H'); order.
+ apply find_1; auto.
+ rewrite remove_min_mapsto; auto.
+ rewrite find_mapsto_equiv; eauto; intros.
+ rewrite remove_min_mapsto; intuition; order.
+Qed.
+
+(** * Merging two trees *)
+
+Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 ->
+ (In y (merge m1 m2) <-> In y m1 \/ In y m2).
+Proof.
+ intros m1 m2; functional induction (merge m1 m2);intros;
+  try factornode _x _x0 _x1 _x2 _x3 as m1.
+ intuition_in.
+ intuition_in.
+ rewrite bal_in, remove_min_in, e1; simpl; intuition.
+Qed.
+
+Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 ->
+  (MapsTo y e (merge m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2).
+Proof.
+ intros m1 m2; functional induction (merge m1 m2); intros;
+  try factornode _x _x0 _x1 _x2 _x3 as m1.
+ intuition_in.
+ intuition_in.
+ rewrite bal_mapsto, remove_min_mapsto, e1; simpl; auto.
+ unfold create.
+ intuition; subst; auto.
+ inversion_clear H1; intuition.
+Qed.
+
+Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 ->
+ (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) ->
+ bst (merge m1 m2).
+Proof.
+ intros m1 m2; functional induction (merge m1 m2); intros; auto;
+ try factornode _x _x0 _x1 _x2 _x3 as m1.
+ apply bal_bst; auto.
+ generalize (remove_min_bst H0); rewrite e1; simpl in *; auto.
+ intro; intro.
+ apply H1; auto.
+ generalize (remove_min_in l2 x2 d2 r2 _x4 x); rewrite e1; simpl; intuition.
+ generalize (remove_min_gt_tree H0); rewrite e1; simpl; auto.
+Qed.
+
+(** * Deletion *)
+
+Lemma remove_in : forall m x y, bst m ->
+ (In y (remove x m) <-> ~ X.eq y x /\ In y m).
+Proof.
+ intros m x; functional induction (remove x m); simpl; intros.
+ intuition_in.
+ (* LT *)
+ inv bst; clear e0.
+ rewrite bal_in; auto.
+ generalize (IHt y0 H0); intuition; [ order | order | intuition_in ].
+ (* EQ *)
+ inv bst; clear e0.
+ rewrite merge_in; intuition; [ order | order | intuition_in ].
+ elim H4; eauto.
+ (* GT *)
+ inv bst; clear e0.
+ rewrite bal_in; auto.
+ generalize (IHt y0 H1); intuition; [ order | order | intuition_in ].
+Qed.
+
+Lemma remove_bst : forall m x, bst m -> bst (remove x m).
+Proof.
+ intros m x; functional induction (remove x m); simpl; intros.
+ auto.
+ (* LT *)
+ inv bst.
+ apply bal_bst; auto.
+ intro; intro.
+ rewrite (remove_in x y0 H0) in H; auto.
+ destruct H; eauto.
+ (* EQ *)
+ inv bst.
+ apply merge_bst; eauto.
+ (* GT *)
+ inv bst.
+ apply bal_bst; auto.
+ intro; intro.
+ rewrite (remove_in x y0 H1) in H; auto.
+ destruct H; eauto.
+Qed.
+
+Lemma remove_1 : forall m x y, bst m -> X.eq x y -> ~ In y (remove x m).
+Proof.
+ intros; rewrite remove_in; intuition.
+Qed.
+
+Lemma remove_2 : forall m x y e, bst m -> ~X.eq x y ->
+ MapsTo y e m -> MapsTo y e (remove x m).
+Proof.
+ intros m x y e; induction m; simpl; auto.
+ destruct (X.compare x k);
+   intros; inv bst; try rewrite bal_mapsto; unfold create; auto;
+   try solve [inv MapsTo; auto].
+ rewrite merge_mapsto; auto.
+ inv MapsTo; auto; order.
+Qed.
+
+Lemma remove_3 : forall m x y e, bst m ->
+ MapsTo y e (remove x m) -> MapsTo y e m.
+Proof.
+ intros m x y e; induction m; simpl; auto.
+ destruct (X.compare x k); intros Bs; inv bst;
+  try rewrite bal_mapsto; auto; unfold create.
+  intros; inv MapsTo; auto.
+  rewrite merge_mapsto; intuition.
+  intros; inv MapsTo; auto.
+Qed.
+
+(** * join *)
+
+Lemma join_in : forall l x d r y,
+ In y (join l x d r) <-> X.eq y x \/ In y l \/ In y r.
+Proof.
+ join_tac.
+ simpl.
+ rewrite add_in; intuition_in.
+ rewrite add_in; intuition_in.
+ rewrite bal_in, Hlr; clear Hlr Hrl; intuition_in.
+ rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in.
+ apply create_in.
+Qed.
+
+Lemma join_bst : forall l x d r, bst l -> bst r ->
+ lt_tree x l -> gt_tree x r -> bst (join l x d r).
+Proof.
+ join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto;
+ clear Hrl Hlr; intro; intros; rewrite join_in in *.
+ intuition; [ apply MX.lt_eq with x | ]; eauto.
+ intuition; [ apply MX.eq_lt with x | ]; eauto.
+Qed.
+Hint Resolve join_bst : core.
+
+Lemma join_find : forall l x d r y,
+ bst l -> bst r -> lt_tree x l -> gt_tree x r ->
+ find y (join l x d r) = find y (create l x d r).
+Proof.
+ join_tac; auto; inv bst;
+  simpl (join (Leaf elt));
+  try (assert (X.lt lx x) by auto);
+  try (assert (X.lt x rx) by auto);
+  rewrite ?add_find, ?bal_find; auto.
+
+ simpl; destruct X.compare; auto.
+ rewrite not_find_iff; auto; intro; order.
+
+ simpl; repeat (destruct X.compare; auto); try (order; fail).
+ rewrite not_find_iff by auto; intro.
+ assert (X.lt y x) by auto; order.
+
+ simpl; rewrite Hlr; simpl; auto.
+ repeat (destruct X.compare; auto); order.
+ intros u Hu; rewrite join_in in Hu.
+  destruct Hu as [Hu|[Hu|Hu]]; try generalize (H2 _ Hu); order.
+
+ simpl; rewrite Hrl; simpl; auto.
+ repeat (destruct X.compare; auto); order.
+ intros u Hu; rewrite join_in in Hu.
+  destruct Hu as [Hu|[Hu|Hu]]; order.
+Qed.
+
+(** * split *)
+
+Lemma split_in_1 : forall m x, bst m -> forall y,
+ (In y (split x m)#l <-> In y m /\ X.lt y x).
+Proof.
+ intros m x; functional induction (split x m); simpl; intros;
+  inv bst; try clear e0.
+ intuition_in.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
+ intuition_in; order.
+ rewrite join_in.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
+Qed.
+
+Lemma split_in_2 : forall m x, bst m -> forall y,
+ (In y (split x m)#r <-> In y m /\ X.lt x y).
+Proof.
+ intros m x; functional induction (split x m); subst; simpl; intros;
+  inv bst; try clear e0.
+ intuition_in.
+ rewrite join_in.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
+ intuition_in; order.
+ rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order.
+Qed.
+
+Lemma split_in_3 : forall m x, bst m ->
+ (split x m)#o = find x m.
+Proof.
+ intros m x; functional induction (split x m); subst; simpl; auto;
+  intros; inv bst; try clear e0;
+  destruct X.compare; try order; trivial; rewrite <- IHt, e1; auto.
+Qed.
+
+Lemma split_bst : forall m x, bst m ->
+ bst (split x m)#l /\ bst (split x m)#r.
+Proof.
+ intros m x; functional induction (split x m); subst; simpl; intros;
+  inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition;
+  apply join_bst; auto.
+ intros y0.
+ generalize (split_in_2 x H0 y0); rewrite e1; simpl; intuition.
+ intros y0.
+ generalize (split_in_1 x H1 y0); rewrite e1; simpl; intuition.
+Qed.
+
+Lemma split_lt_tree : forall m x, bst m -> lt_tree x (split x m)#l.
+Proof.
+ intros m x B y Hy; rewrite split_in_1 in Hy; intuition.
+Qed.
+
+Lemma split_gt_tree : forall m x, bst m -> gt_tree x (split x m)#r.
+Proof.
+ intros m x B y Hy; rewrite split_in_2 in Hy; intuition.
+Qed.
+
+Lemma split_find : forall m x y, bst m ->
+ find y m = match X.compare y x with
+              | LT _ => find y (split x m)#l
+              | EQ _ => (split x m)#o
+              | GT _ => find y (split x m)#r
+            end.
+Proof.
+ intros m x; functional induction (split x m); subst; simpl; intros;
+  inv bst; try clear e0; try rewrite e1 in *; simpl in *;
+  [ destruct X.compare; auto | .. ];
+  try match goal with E:split ?x ?t = _, B:bst ?t |- _ =>
+      generalize (split_in_1 x B)(split_in_2 x B)(split_bst x B);
+       rewrite E; simpl; destruct 3 end.
+
+ rewrite join_find, IHt; auto; clear IHt; simpl.
+ repeat (destruct X.compare; auto); order.
+ intro y1; rewrite H4; intuition.
+
+ repeat (destruct X.compare; auto); order.
+
+ rewrite join_find, IHt; auto; clear IHt; simpl.
+ repeat (destruct X.compare; auto); order.
+ intros y1; rewrite H; intuition.
+Qed.
+
+(** * Concatenation *)
+
+Lemma concat_in : forall m1 m2 y,
+ In y (concat m1 m2) <-> In y m1 \/ In y m2.
+Proof.
+ intros m1 m2; functional induction (concat m1 m2); intros;
+  try factornode _x _x0 _x1 _x2 _x3 as m1.
+ intuition_in.
+ intuition_in.
+ rewrite join_in, remove_min_in, e1; simpl; intuition.
+Qed.
+
+Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 ->
+ (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) ->
+ bst (concat m1 m2).
+Proof.
+ intros m1 m2; functional induction (concat m1 m2); intros; auto;
+ try factornode _x _x0 _x1 _x2 _x3 as m1.
+ apply join_bst; auto.
+ change (bst (m2',xd)#1). rewrite <-e1; eauto.
+ intros y Hy.
+ apply H1; auto.
+ rewrite remove_min_in, e1; simpl; auto.
+ change (gt_tree (m2',xd)#2#1 (m2',xd)#1). rewrite <-e1; eauto.
+Qed.
+Hint Resolve concat_bst : core.
+
+Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 ->
+ (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) ->
+ find y (concat m1 m2) =
+  match find y m2 with Some d => Some d | None => find y m1 end.
+Proof.
+ intros m1 m2; functional induction (concat m1 m2); intros; auto;
+ try factornode _x _x0 _x1 _x2 _x3 as m1.
+ simpl; destruct (find y m2); auto.
+
+ generalize (remove_min_find y H0)(remove_min_in l2 x2 d2 r2 _x4)
+  (remove_min_bst H0)(remove_min_gt_tree H0);
+  rewrite e1; simpl fst; simpl snd; intros.
+
+ inv bst.
+ rewrite H2, join_find; auto; clear H2.
+ simpl; destruct X.compare as [Hlt| |Hlt]; simpl; auto.
+ destruct (find y m2'); auto.
+ symmetry; rewrite not_find_iff; auto; intro.
+ apply (MX.lt_not_gt Hlt); apply H1; auto; rewrite H3; auto.
+
+ intros z Hz; apply H1; auto; rewrite H3; auto.
+Qed.
+
+
+(** * Elements *)
+
+Notation eqk := (PX.eqk (elt:= elt)).
+Notation eqke := (PX.eqke (elt:= elt)).
+Notation ltk := (PX.ltk (elt:= elt)).
+
+Lemma elements_aux_mapsto : forall (s:t elt) acc x e,
+ InA eqke (x,e) (elements_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc.
+Proof.
+ induction s as [ | l Hl x e r Hr h ]; simpl; auto.
+ intuition.
+ inversion H0.
+ intros.
+ rewrite Hl.
+ destruct (Hr acc x0 e0); clear Hl Hr.
+ intuition; inversion_clear H3; intuition.
+ destruct H0; simpl in *; subst; intuition.
+Qed.
+
+Lemma elements_mapsto : forall (s:t elt) x e, InA eqke (x,e) (elements s) <-> MapsTo x e s.
+Proof.
+ intros; generalize (elements_aux_mapsto s nil x e); intuition.
+ inversion_clear H0.
+Qed.
+
+Lemma elements_in : forall (s:t elt) x, L.PX.In x (elements s) <-> In x s.
+Proof.
+ intros.
+ unfold L.PX.In.
+ rewrite <- In_alt; unfold In0.
+ firstorder.
+ exists x0.
+ rewrite <- elements_mapsto; auto.
+ exists x0.
+ unfold L.PX.MapsTo; rewrite elements_mapsto; auto.
+Qed.
+
+Lemma elements_aux_sort : forall (s:t elt) acc, bst s -> sort ltk acc ->
+ (forall x e y, InA eqke (x,e) acc -> In y s -> X.lt y x) ->
+ sort ltk (elements_aux acc s).
+Proof.
+ induction s as [ | l Hl y e r Hr h]; simpl; intuition.
+ inv bst.
+ apply Hl; auto.
+ constructor.
+ apply Hr; eauto.
+ apply InA_InfA with (eqA:=eqke); auto with *. intros (y',e') H6.
+ destruct (elements_aux_mapsto r acc y' e'); intuition.
+ red; simpl; eauto.
+ red; simpl; eauto.
+ intros.
+ inversion_clear H.
+ destruct H7; simpl in *.
+ order.
+ destruct (elements_aux_mapsto r acc x e0); intuition eauto. 
+Qed.
+
+Lemma elements_sort : forall s : t elt, bst s -> sort ltk (elements s).
+Proof.
+ intros; unfold elements; apply elements_aux_sort; auto.
+ intros; inversion H0.
+Qed.
+Hint Resolve elements_sort : core.
+
+Lemma elements_nodup : forall s : t elt, bst s -> NoDupA eqk (elements s).
+Proof.
+ intros; apply PX.Sort_NoDupA; auto.
+Qed.
+
+Lemma elements_aux_cardinal :
+ forall (m:t elt) acc, (length acc + cardinal m)%nat = length (elements_aux acc m).
+Proof.
+ simple induction m; simpl; intuition.
+ rewrite <- H; simpl.
+ rewrite <- H0; omega.
+Qed.
+
+Lemma elements_cardinal : forall (m:t elt), cardinal m = length (elements m).
+Proof.
+ exact (fun m => elements_aux_cardinal m nil).
+Qed.
+
+Lemma elements_app :
+ forall (s:t elt) acc, elements_aux acc s = elements s ++ acc.
+Proof.
+ induction s; simpl; intros; auto.
+ rewrite IHs1, IHs2.
+ unfold elements; simpl.
+ rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto.
+Qed.
+
+Lemma elements_node :
+ forall (t1 t2:t elt) x e z l,
+ elements t1 ++ (x,e) :: elements t2 ++ l =
+ elements (Node t1 x e t2 z) ++ l.
+Proof.
+ unfold elements; simpl; intros.
+ rewrite !elements_app, !app_nil_r, !app_ass; auto.
+Qed.
+
+(** * Fold *)
+
+Definition fold' (A : Type) (f : key -> elt -> A -> A)(s : t elt) :=
+  L.fold f (elements s).
+
+Lemma fold_equiv_aux :
+ forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A) acc,
+ L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a).
+Proof.
+ simple induction s.
+ simpl; intuition.
+ simpl; intros.
+ rewrite H.
+ simpl.
+ apply H0.
+Qed.
+
+Lemma fold_equiv :
+ forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A),
+ fold f s a = fold' f s a.
+Proof.
+ unfold fold', elements.
+ simple induction s; simpl; auto; intros.
+ rewrite fold_equiv_aux.
+ rewrite H0.
+ simpl; auto.
+Qed.
+
+Lemma fold_1 :
+ forall (s:t elt)(Hs:bst s)(A : Type)(i:A)(f : key -> elt -> A -> A),
+ fold f s i = fold_left (fun a p => f p#1 p#2 a) (elements s) i.
+Proof.
+ intros.
+ rewrite fold_equiv.
+ unfold fold'.
+ rewrite L.fold_1.
+ unfold L.elements; auto.
+Qed.
+
+(** * Comparison *)
+
+(** [flatten_e e] returns the list of elements of the enumeration [e]
+    i.e. the list of elements actually compared *)
+
+Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with
+  | End _ => nil
+  | More x e t r => (x,e) :: elements t ++ flatten_e r
+ end.
+
+Lemma flatten_e_elements :
+ forall (l:t elt) r x d z e,
+ elements l ++ flatten_e (More x d r e) =
+ elements (Node l x d r z) ++ flatten_e e.
+Proof.
+ intros; apply elements_node.
+Qed.
+
+Lemma cons_1 : forall (s:t elt) e,
+  flatten_e (cons s e) = elements s ++ flatten_e e.
+Proof.
+  induction s; auto; intros.
+  simpl flatten_e; rewrite IHs1; apply flatten_e_elements; auto.
+Qed.
+
+(** Proof of correction for the comparison *)
+
+Variable cmp : elt->elt->bool.
+
+Definition IfEq b l1 l2 := L.equal cmp l1 l2 = b.
+
+Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2,
+  X.eq x1 x2 -> cmp d1 d2 = true ->
+  IfEq b l1 l2 ->
+    IfEq b ((x1,d1)::l1) ((x2,d2)::l2).
+Proof.
+ unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl;
+  try rewrite H0; auto; order.
+Qed.
+
+Lemma equal_end_IfEq : forall e2,
+  IfEq (equal_end e2) nil (flatten_e e2).
+Proof.
+ destruct e2; red; auto.
+Qed.
+
+Lemma equal_more_IfEq :
+ forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l,
+  IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) ->
+    IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l)
+       (flatten_e (More x2 d2 r2 e2)).
+Proof.
+ unfold IfEq; simpl; intros; destruct X.compare; simpl; auto.
+ rewrite <-andb_lazy_alt; f_equal; auto.
+Qed.
+
+Lemma equal_cont_IfEq : forall m1 cont e2 l,
+  (forall e, IfEq (cont e) l (flatten_e e)) ->
+  IfEq (equal_cont cmp m1 cont e2) (elements m1 ++ l) (flatten_e e2).
+Proof.
+ induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; intros; auto.
+ rewrite <- elements_node; simpl.
+ apply Hl1; auto.
+ clear e2; intros [|x2 d2 r2 e2].
+ simpl; red; auto.
+ apply equal_more_IfEq.
+ rewrite <- cons_1; auto.
+Qed.
+
+Lemma equal_IfEq : forall (m1 m2:t elt),
+  IfEq (equal cmp m1 m2) (elements m1) (elements m2).
+Proof.
+ intros; unfold equal.
+ rewrite <- (app_nil_r (elements m1)).
+ replace (elements m2) with (flatten_e (cons m2 (End _)))
+  by (rewrite cons_1; simpl; rewrite app_nil_r; auto).
+ apply equal_cont_IfEq.
+ intros.
+ apply equal_end_IfEq; auto.
+Qed.
+
+Definition Equivb m m' :=
+  (forall k, In k m <-> In k m') /\
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
+
+Lemma Equivb_elements : forall s s',
+ Equivb s s' <-> L.Equivb cmp (elements s) (elements s').
+Proof.
+unfold Equivb, L.Equivb; split; split; intros.
+do 2 rewrite elements_in; firstorder.
+destruct H.
+apply (H2 k); rewrite <- elements_mapsto; auto.
+do 2 rewrite <- elements_in; firstorder.
+destruct H.
+apply (H2 k); unfold L.PX.MapsTo; rewrite elements_mapsto; auto.
+Qed.
+
+Lemma equal_Equivb : forall (s s': t elt), bst s -> bst s' ->
+  (equal cmp s s' = true <-> Equivb s s').
+Proof.
+ intros s s' B B'.
+ rewrite Equivb_elements, <- equal_IfEq.
+ split; [apply L.equal_2|apply L.equal_1]; auto.
+Qed.
+
+End Elt.
+
+Section Map.
+Variable elt elt' : Type.
+Variable f : elt -> elt'.
+
+Lemma map_1 : forall (m: t elt)(x:key)(e:elt),
+    MapsTo x e m -> MapsTo x (f e) (map f m).
+Proof.
+induction m; simpl; inversion_clear 1; auto.
+Qed.
+
+Lemma map_2 : forall (m: t elt)(x:key),
+    In x (map f m) -> In x m.
+Proof.
+induction m; simpl; inversion_clear 1; auto.
+Qed.
+
+Lemma map_bst : forall m, bst m -> bst (map f m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto;
+ red; auto using map_2.
+Qed.
+
+End Map.
+Section Mapi.
+Variable elt elt' : Type.
+Variable f : key -> elt -> elt'.
+
+Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt),
+    MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
+Proof.
+induction m; simpl; inversion_clear 1; auto.
+exists k; auto.
+destruct (IHm1 _ _ H0).
+exists x0; intuition.
+destruct (IHm2 _ _ H0).
+exists x0; intuition.
+Qed.
+
+Lemma mapi_2 : forall (m: t elt)(x:key),
+    In x (mapi f m) -> In x m.
+Proof.
+induction m; simpl; inversion_clear 1; auto.
+Qed.
+
+Lemma mapi_bst : forall m, bst m -> bst (mapi f m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto;
+ red; auto using mapi_2.
+Qed.
+
+End Mapi.
+
+Section Map_option.
+Variable elt elt' : Type.
+Variable f : key -> elt -> option elt'.
+Hypothesis f_compat : forall x x' d, X.eq x x' -> f x d = f x' d.
+
+Lemma map_option_2 : forall (m:t elt)(x:key),
+ In x (map_option f m) -> exists d, MapsTo x d m /\ f x d <> None.
+Proof.
+intros m; functional induction (map_option f m); simpl; auto; intros.
+inversion H.
+rewrite join_in in H; destruct H as [H|[H|H]].
+exists d; split; auto; rewrite (f_compat d H), e0; discriminate.
+destruct (IHt _ H) as (d0 & ? & ?); exists d0; auto.
+destruct (IHt0 _ H) as (d0 & ? & ?); exists d0; auto.
+rewrite concat_in in H; destruct H as [H|H].
+destruct (IHt _ H) as (d0 & ? & ?); exists d0; auto.
+destruct (IHt0 _ H) as (d0 & ? & ?); exists d0; auto.
+Qed.
+
+Lemma map_option_bst : forall m, bst m -> bst (map_option f m).
+Proof.
+intros m; functional induction (map_option f m); simpl; auto; intros;
+ inv bst.
+apply join_bst; auto; intros y H;
+ destruct (map_option_2 H) as (d0 & ? & ?); eauto using MapsTo_In.
+apply concat_bst; auto; intros y y' H H'.
+destruct (map_option_2 H) as (d0 & ? & ?).
+destruct (map_option_2 H') as (d0' & ? & ?).
+eapply X.lt_trans with x; eauto using MapsTo_In.
+Qed.
+Hint Resolve map_option_bst : core.
+
+Ltac nonify e :=
+ replace e with (@None elt) by
+  (symmetry; rewrite not_find_iff; auto; intro; order).
+
+Lemma map_option_find : forall (m:t elt)(x:key),
+ bst m ->
+ find x (map_option f m) =
+  match (find x m) with Some d => f x d | None => None end.
+Proof.
+intros m; functional induction (map_option f m); simpl; auto; intros;
+ inv bst; rewrite join_find || rewrite concat_find; auto; simpl;
+ try destruct X.compare as [Hlt|Heq|Hlt]; simpl; auto.
+rewrite (f_compat d Heq); auto.
+intros y H;
+ destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In.
+intros y H;
+ destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In.
+
+rewrite <- IHt, IHt0; auto; nonify (find x0 r); auto.
+rewrite IHt, IHt0; auto; nonify (find x0 r); nonify (find x0 l); auto.
+rewrite (f_compat d Heq); auto.
+rewrite <- IHt0, IHt; auto; nonify (find x0 l); auto.
+ destruct (find x0 (map_option f r)); auto.
+
+intros y y' H H'.
+destruct (map_option_2 H) as (? & ? & ?).
+destruct (map_option_2 H') as (? & ? & ?).
+eapply X.lt_trans with x; eauto using MapsTo_In.
+Qed.
+
+End Map_option.
+
+Section Map2_opt.
+Variable elt elt' elt'' : Type.
+Variable f0 : key -> option elt -> option elt' -> option elt''.
+Variable f : key -> elt -> option elt' -> option elt''.
+Variable mapl : t elt -> t elt''.
+Variable mapr : t elt' -> t elt''.
+Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o.
+Hypothesis mapl_bst : forall m, bst m -> bst (mapl m).
+Hypothesis mapr_bst : forall m', bst m' -> bst (mapr m').
+Hypothesis mapl_f0 : forall x m, bst m ->
+ find x (mapl m) =
+  match find x m with Some d => f0 x (Some d) None | None => None end.
+Hypothesis mapr_f0 : forall x m', bst m' ->
+ find x (mapr m') =
+  match find x m' with Some d' => f0 x None (Some d') | None => None end.
+Hypothesis f0_compat : forall x x' o o', X.eq x x' -> f0 x o o' = f0 x' o o'.
+
+Notation map2_opt := (map2_opt f mapl mapr).
+
+Lemma map2_opt_2 : forall m m' y, bst m -> bst m' ->
+  In y (map2_opt m m') -> In y m \/ In y m'.
+Proof.
+intros m m'; functional induction (map2_opt m m'); intros;
+ auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2;
+ try (generalize (split_in_1 x1 H0 y)(split_in_2 x1 H0 y)
+      (split_bst x1 H0); rewrite e1; simpl; destruct 3; inv bst).
+
+right; apply find_in.
+generalize (in_find (mapr_bst H0) H1); rewrite mapr_f0; auto.
+destruct (find y m2); auto; intros; discriminate.
+
+factornode l1 x1 d1 r1 _x as m1.
+left; apply find_in.
+generalize (in_find (mapl_bst H) H1); rewrite mapl_f0; auto.
+destruct (find y m1); auto; intros; discriminate.
+
+rewrite join_in in H1; destruct H1 as [H'|[H'|H']]; auto.
+destruct (IHt1 y H6 H4 H'); intuition.
+destruct (IHt0 y H7 H5 H'); intuition.
+
+rewrite concat_in in H1; destruct H1 as [H'|H']; auto.
+destruct (IHt1 y H6 H4 H'); intuition.
+destruct (IHt0 y H7 H5 H'); intuition.
+Qed.
+
+Lemma map2_opt_bst : forall m m', bst m -> bst m' ->
+ bst (map2_opt m m').
+Proof.
+intros m m'; functional induction (map2_opt m m'); intros;
+ auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst;
+ generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0);
+  rewrite e1; simpl in *; destruct 3.
+
+apply join_bst; auto.
+intros y Hy; specialize H with y.
+destruct (map2_opt_2 H1 H6 Hy); intuition.
+intros y Hy; specialize H5 with y.
+destruct (map2_opt_2 H2 H7 Hy); intuition.
+
+apply concat_bst; auto.
+intros y y' Hy Hy'; specialize H with y; specialize H5 with y'.
+apply X.lt_trans with x1.
+destruct (map2_opt_2 H1 H6 Hy); intuition.
+destruct (map2_opt_2 H2 H7 Hy'); intuition.
+Qed.
+Hint Resolve map2_opt_bst : core.
+
+Ltac map2_aux :=
+ match goal with
+  | H : In ?x _ \/ In ?x ?m,
+    H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ =>
+    destruct H; [ intuition_in; order |
+                  rewrite <-(find_in_equiv B B' H'); auto ]
+ end.
+
+Ltac nonify t :=
+ match t with (find ?y (map2_opt ?m ?m')) =>
+ replace t with (@None elt'');
+ [ | symmetry; rewrite not_find_iff; auto; intro;
+     destruct (@map2_opt_2 m m' y); auto; order ]
+ end.
+
+Lemma map2_opt_1 : forall m m' y, bst m -> bst m' ->
+ In y m \/ In y m' ->
+ find y (map2_opt m m') = f0 y (find y m) (find y m').
+Proof.
+intros m m'; functional induction (map2_opt m m'); intros;
+ auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2;
+ try (generalize (split_in_1 x1 H0)(split_in_2 x1 H0)
+       (split_in_3 x1 H0)(split_bst x1 H0)(split_find x1 y H0)
+       (split_lt_tree (x:=x1) H0)(split_gt_tree (x:=x1) H0);
+       rewrite e1; simpl in *; destruct 4; intros; inv bst;
+      subst o2; rewrite H7, ?join_find, ?concat_find; auto).
+
+simpl; destruct H1; [ inversion_clear H1 | ].
+rewrite mapr_f0; auto.
+generalize (in_find H0 H1); destruct (find y m2); intuition.
+
+factornode l1 x1 d1 r1 _x as m1.
+destruct H1; [ | inversion_clear H1 ].
+rewrite mapl_f0; auto.
+generalize (in_find H H1); destruct (find y m1); intuition.
+
+simpl; destruct X.compare; auto.
+apply IHt1; auto; map2_aux.
+rewrite (@f0_compat y x1), <- f0_f; auto.
+apply IHt0; auto; map2_aux.
+intros z Hz; destruct (@map2_opt_2 l1 l2' z); auto.
+intros z Hz; destruct (@map2_opt_2 r1 r2' z); auto.
+
+destruct X.compare.
+nonify (find y (map2_opt r1 r2')).
+apply IHt1; auto; map2_aux.
+nonify (find y (map2_opt r1 r2')).
+nonify (find y (map2_opt l1 l2')).
+rewrite (@f0_compat y x1), <- f0_f; auto.
+nonify (find y (map2_opt l1 l2')).
+rewrite IHt0; auto; [ | map2_aux ].
+destruct (f0 y (find y r1) (find y r2')); auto.
+intros y1 y2 Hy1 Hy2; apply X.lt_trans with x1.
+ destruct (@map2_opt_2 l1 l2' y1); auto.
+ destruct (@map2_opt_2 r1 r2' y2); auto.
+Qed.
+
+End Map2_opt.
+
+Section Map2.
+Variable elt elt' elt'' : Type.
+Variable f : option elt -> option elt' -> option elt''.
+
+Lemma map2_bst : forall m m', bst m -> bst m' -> bst (map2 f m m').
+Proof.
+unfold map2; intros.
+apply map2_opt_bst with (fun _ => f); auto using map_option_bst;
+ intros; rewrite map_option_find; auto.
+Qed.
+
+Lemma map2_1 : forall m m' y, bst m -> bst m' ->
+  In y m \/ In y m' -> find y (map2 f m m') = f (find y m) (find y m').
+Proof.
+unfold map2; intros.
+rewrite (map2_opt_1 (f0:=fun _ => f));
+ auto using map_option_bst; intros; rewrite map_option_find; auto.
+Qed.
+
+Lemma map2_2 : forall m m' y, bst m -> bst m' ->
+  In y (map2 f m m') -> In y m \/ In y m'.
+Proof.
+unfold map2; intros.
+eapply map2_opt_2 with (f0:=fun _ => f); try eassumption; trivial; intros.
+ apply map_option_bst; auto.
+ apply map_option_bst; auto.
+ rewrite map_option_find; auto.
+ rewrite map_option_find; auto.
+Qed.
+
+End Map2.
+End Proofs.
+End Raw.
+
+(** * Encapsulation
+
+   Now, in order to really provide a functor implementing [S], we
+   need to encapsulate everything into a type of balanced binary search trees. *)
+
+Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
+
+ Module E := X.
+ Module Raw := Raw I X.
+ Import Raw.Proofs.
+
+ #[universes(template)]
+ Record bst (elt:Type) :=
+  Bst {this :> Raw.tree elt; is_bst : Raw.bst this}.
+
+ Definition t := bst.
+ Definition key := E.t.
+
+ Section Elt.
+ Variable elt elt' elt'': Type.
+
+ Implicit Types m : t elt.
+ Implicit Types x y : key.
+ Implicit Types e : elt.
+
+ Definition empty : t elt := Bst (empty_bst elt).
+ Definition is_empty m : bool := Raw.is_empty (this m).
+ Definition add x e m : t elt := Bst (add_bst x e (is_bst m)).
+ Definition remove x m : t elt := Bst (remove_bst x (is_bst m)).
+ Definition mem x m : bool := Raw.mem x (this m).
+ Definition find x m : option elt := Raw.find x (this m).
+ Definition map f m : t elt' := Bst (map_bst f (is_bst m)).
+ Definition mapi (f:key->elt->elt') m : t elt' :=
+  Bst (mapi_bst f (is_bst m)).
+ Definition map2 f m (m':t elt') : t elt'' :=
+  Bst (map2_bst f (is_bst m) (is_bst m')).
+ Definition elements m : list (key*elt) := Raw.elements (this m).
+ Definition cardinal m := Raw.cardinal (this m).
+ Definition fold (A:Type) (f:key->elt->A->A) m i := Raw.fold (A:=A) f (this m) i.
+ Definition equal cmp m m' : bool := Raw.equal cmp (this m) (this m').
+
+ Definition MapsTo x e m : Prop := Raw.MapsTo x e (this m).
+ Definition In x m : Prop := Raw.In0 x (this m).
+ Definition Empty m : Prop := Empty (this m).
+
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt.
+ Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt.
+
+ Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
+ Proof. intros m; exact (@MapsTo_1 _ (this m)). Qed.
+
+ Lemma mem_1 : forall m x, In x m -> mem x m = true.
+ Proof.
+ unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto.
+ apply (is_bst m).
+ Qed.
+
+ Lemma mem_2 : forall m x, mem x m = true -> In x m.
+ Proof.
+ unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto.
+ Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact (@empty_1 elt). Qed.
+
+ Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
+ Proof. intros m; exact (@is_empty_1 _ (this m)). Qed.
+ Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+ Proof. intros m; exact (@is_empty_2 _ (this m)). Qed.
+
+ Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
+ Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed.
+ Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+ Proof. intros m x y e e'; exact (@add_2 elt _ x y e e'). Qed.
+ Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+ Proof. intros m x y e e'; exact (@add_3 elt _ x y e e'). Qed.
+
+ Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
+ Proof.
+ unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto.
+ apply (is_bst m).
+ Qed.
+ Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+ Proof. intros m x y e; exact (@remove_2 elt _ x y e (is_bst m)). Qed.
+ Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
+ Proof. intros m x y e; exact (@remove_3 elt _ x y e (is_bst m)). Qed.
+
+
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
+ Proof. intros m x e; exact (@find_1 elt _ x e (is_bst m)). Qed.
+ Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+ Proof. intros m; exact (@find_2 elt (this m)). Qed.
+
+ Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+ Proof. intros m; exact (@fold_1 elt (this m) (is_bst m)). Qed.
+
+ Lemma elements_1 : forall m x e,
+   MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+ Proof.
+ intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto.
+ Qed.
+
+ Lemma elements_2 : forall m x e,
+   InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+ Proof.
+ intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto.
+ Qed.
+
+ Lemma elements_3 : forall m, sort lt_key (elements m).
+ Proof. intros m; exact (@elements_sort elt (this m) (is_bst m)). Qed.
+
+ Lemma elements_3w : forall m, NoDupA eq_key (elements m).
+ Proof. intros m; exact (@elements_nodup elt (this m) (is_bst m)). Qed.
+
+ Lemma cardinal_1 : forall m, cardinal m = length (elements m).
+ Proof. intro m; exact (@elements_cardinal elt (this m)). Qed.
+
+ Definition Equal m m' := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+   (forall k, In k m <-> In k m') /\
+   (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+ Definition Equivb cmp := Equiv (Cmp cmp).
+
+ Lemma Equivb_Equivb : forall cmp m m',
+  Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'.
+ Proof.
+ intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In. intuition. 
+ generalize (H0 k); do 2 rewrite In_alt; intuition.
+ generalize (H0 k); do 2 rewrite In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- In_alt; intuition.
+ Qed.
+
+ Lemma equal_1 : forall m m' cmp,
+   Equivb cmp m m' -> equal cmp m m' = true.
+ Proof.
+ unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb;
+  intros; simpl in *; rewrite equal_Equivb; auto.
+ Qed.
+
+ Lemma equal_2 : forall m m' cmp,
+   equal cmp m m' = true -> Equivb cmp m m'.
+ Proof.
+ unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb;
+  intros; simpl in *; rewrite <-equal_Equivb; auto.
+ Qed.
+
+ End Elt.
+
+ Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+ Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f (this m) x e). Qed.
+
+ Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m.
+ Proof.
+ intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl.
+ apply map_2; auto.
+ Qed.
+
+ Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m ->
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+ Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f (this m) x e). Qed.
+ Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+ Proof.
+ intros elt elt' m x f; unfold In in *; do 2 rewrite In_alt; simpl; apply mapi_2; auto.
+ Qed.
+
+ Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
+    (x:key)(f:option elt->option elt'->option elt''),
+    In x m \/ In x m' ->
+    find x (map2 f m m') = f (find x m) (find x m').
+ Proof.
+ unfold find, map2, In; intros elt elt' elt'' m m' x f.
+ do 2 rewrite In_alt; intros; simpl; apply map2_1; auto.
+ apply (is_bst m).
+ apply (is_bst m').
+ Qed.
+
+ Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
+     (x:key)(f:option elt->option elt'->option elt''),
+     In x (map2 f m m') -> In x m \/ In x m'.
+ Proof.
+ unfold In, map2; intros elt elt' elt'' m m' x f.
+ do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto.
+ apply (is_bst m).
+ apply (is_bst m').
+ Qed.
+
+End IntMake.
+
+
+Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
+    Sord with Module Data := D
+         with Module MapS.E := X.
+
+  Module Data := D.
+  Module Import MapS := IntMake(I)(X).
+  Module LO := FMapList.Make_ord(X)(D).
+  Module R := Raw.
+  Module P := Raw.Proofs.
+
+  Definition t := MapS.t D.t.
+
+  Definition cmp e e' :=
+   match D.compare e e' with EQ _ => true | _ => false end.
+
+  (** One step of comparison of elements *)
+
+  Definition compare_more x1 d1 (cont:R.enumeration D.t -> comparison) e2 :=
+   match e2 with
+    | R.End _ => Gt
+    | R.More x2 d2 r2 e2 =>
+       match X.compare x1 x2 with
+        | EQ _ => match D.compare d1 d2 with
+                   | EQ _ => cont (R.cons r2 e2)
+                   | LT _ => Lt
+                   | GT _ => Gt
+                  end
+        | LT _ => Lt
+        | GT _ => Gt
+       end
+   end.
+
+  (** Comparison of left tree, middle element, then right tree *)
+
+  Fixpoint compare_cont s1 (cont:R.enumeration D.t -> comparison) e2 :=
+   match s1 with
+    | R.Leaf _ => cont e2
+    | R.Node l1 x1 d1 r1 _ =>
+       compare_cont l1 (compare_more x1 d1 (compare_cont r1 cont)) e2
+   end.
+
+  (** Initial continuation *)
+
+  Definition compare_end (e2:R.enumeration D.t) :=
+   match e2 with R.End _ => Eq | _ => Lt end.
+
+  (** The complete comparison *)
+
+  Definition compare_pure s1 s2 :=
+   compare_cont s1 compare_end (R.cons s2 (Raw.End _)).
+
+  (** Correctness of this comparison *)
+
+  Definition Cmp c :=
+   match c with
+    | Eq => LO.eq_list
+    | Lt => LO.lt_list
+    | Gt => (fun l1 l2 => LO.lt_list l2 l1)
+   end.
+
+  Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2,
+   X.eq x1 x2 -> D.eq d1 d2 ->
+   Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2).
+  Proof.
+   destruct c; simpl; intros; P.MX.elim_comp; auto.
+  Qed.
+  Hint Resolve cons_Cmp : core.
+
+  Lemma compare_end_Cmp :
+   forall e2, Cmp (compare_end e2) nil (P.flatten_e e2).
+  Proof.
+   destruct e2; simpl; auto.
+  Qed.
+
+  Lemma compare_more_Cmp : forall x1 d1 cont x2 d2 r2 e2 l,
+    Cmp (cont (R.cons r2 e2)) l (R.elements r2 ++ P.flatten_e e2) ->
+     Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l)
+       (P.flatten_e (R.More x2 d2 r2 e2)).
+  Proof.
+   simpl; intros; destruct X.compare; simpl;
+    try destruct D.compare; simpl; auto; P.MX.elim_comp; auto.
+  Qed.
+
+  Lemma compare_cont_Cmp : forall s1 cont e2 l,
+   (forall e, Cmp (cont e) l (P.flatten_e e)) ->
+   Cmp (compare_cont s1 cont e2) (R.elements s1 ++ l) (P.flatten_e e2).
+  Proof.
+   induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; intros; auto.
+   rewrite <- P.elements_node; simpl.
+   apply Hl1; auto. clear e2. intros [|x2 d2 r2 e2].
+   simpl; auto.
+   apply compare_more_Cmp.
+   rewrite <- P.cons_1; auto.
+  Qed.
+
+  Lemma compare_Cmp : forall s1 s2,
+   Cmp (compare_pure s1 s2) (R.elements s1) (R.elements s2).
+  Proof.
+   intros; unfold compare_pure.
+   rewrite <- (app_nil_r (R.elements s1)).
+   replace (R.elements s2) with (P.flatten_e (R.cons s2 (R.End _))) by
+    (rewrite P.cons_1; simpl; rewrite app_nil_r; auto).
+   auto using compare_cont_Cmp, compare_end_Cmp.
+  Qed.
+
+  (** The dependent-style [compare] *)
+
+  Definition eq (m1 m2 : t) := LO.eq_list (elements m1) (elements m2).
+  Definition lt (m1 m2 : t) := LO.lt_list (elements m1) (elements m2).
+
+  Definition compare (s s':t) : Compare lt eq s s'.
+  Proof.
+   destruct s as (s,b), s' as (s',b').
+   generalize (compare_Cmp s s').
+   destruct compare_pure; intros; [apply EQ|apply LT|apply GT]; red; auto.
+  Defined.
+
+  (* Proofs about [eq] and [lt] *)
+
+  Definition selements (m1 : t) :=
+   LO.MapS.Build_slist (P.elements_sort (is_bst m1)).
+
+  Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2).
+  Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2).
+
+  Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2.
+  Proof.
+   unfold eq, seq, selements, elements, LO.eq; intuition.
+  Qed.
+
+  Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2.
+  Proof.
+   unfold lt, slt, selements, elements, LO.lt; intuition.
+  Qed.
+
+  Lemma eq_1 : forall (m m' : t), Equivb cmp m m' -> eq m m'.
+  Proof.
+  intros m m'.
+  rewrite eq_seq; unfold seq.
+  rewrite Equivb_Equivb.
+  rewrite P.Equivb_elements.
+  auto using LO.eq_1.
+  Qed.
+
+  Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'.
+  Proof.
+  intros m m'.
+  rewrite eq_seq; unfold seq.
+  rewrite Equivb_Equivb.
+  rewrite P.Equivb_elements.
+  intros.
+  generalize (LO.eq_2 H).
+  auto.
+  Qed.
+
+  Lemma eq_refl : forall m : t, eq m m.
+  Proof.
+  intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl.
+  Qed.
+
+  Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+  Proof.
+  intros m1 m2; rewrite 2 eq_seq; unfold seq; intros; apply LO.eq_sym; auto.
+  Qed.
+
+  Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
+  Proof.
+  intros m1 m2 M3; rewrite 3 eq_seq; unfold seq.
+   intros; eapply LO.eq_trans; eauto.
+  Qed.
+
+  Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
+  Proof.
+  intros m1 m2 m3; rewrite 3 lt_slt; unfold slt;
+   intros; eapply LO.lt_trans; eauto.
+  Qed.
+
+  Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
+  Proof.
+  intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq;
+   intros; apply LO.lt_not_eq; auto.
+  Qed.
+
+End IntMake_ord.
+
+(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)
+
+Module Make (X: OrderedType) <: S with Module E := X
+ :=IntMake(Z_as_Int)(X).
+
+Module Make_ord (X: OrderedType)(D: OrderedType)
+ <: Sord with Module Data := D
+            with Module MapS.E := X
+ :=IntMake_ord(Z_as_Int)(X)(D).
+
diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v
new file mode 100644
index 0000000000..e68bc5930d
--- /dev/null
+++ b/theories/FSets/FMapFacts.v
@@ -0,0 +1,2198 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * Finite maps library *)
+
+(** This functor derives additional facts from [FMapInterface.S]. These
+  facts are mainly the specifications of [FMapInterface.S] written using
+  different styles: equivalence and boolean equalities.
+*)
+
+Require Import Bool DecidableType DecidableTypeEx OrderedType Morphisms.
+Require Export FMapInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Hint Extern 1 (Equivalence _) => constructor; congruence : core.
+
+(** * Facts about weak maps *)
+
+Module WFacts_fun (E:DecidableType)(Import M:WSfun E).
+
+Notation eq_dec := E.eq_dec.
+Definition eqb x y := if eq_dec x y then true else false.
+
+Lemma eq_bool_alt : forall b b', b=b' <-> (b=true <-> b'=true).
+Proof.
+ destruct b; destruct b'; intuition.
+Qed.
+
+Lemma eq_option_alt : forall (elt:Type)(o o':option elt),
+ o=o' <-> (forall e, o=Some e <-> o'=Some e).
+Proof.
+split; intros.
+subst; split; auto.
+destruct o; destruct o'; try rewrite H; auto.
+symmetry; rewrite <- H; auto.
+Qed.
+
+Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt),
+  MapsTo x e m -> MapsTo x e' m -> e=e'.
+Proof.
+intros.
+generalize (find_1 H) (find_1 H0); clear H H0.
+intros; rewrite H in H0; injection H0; auto.
+Qed.
+
+(** ** Specifications written using equivalences *)
+
+Section IffSpec.
+Variable elt elt' elt'': Type.
+Implicit Type m: t elt.
+Implicit Type x y z: key.
+Implicit Type e: elt.
+
+Lemma In_iff : forall m x y, E.eq x y -> (In x m <-> In y m).
+Proof.
+unfold In.
+split; intros (e0,H0); exists e0.
+apply (MapsTo_1 H H0); auto.
+apply (MapsTo_1 (E.eq_sym H) H0); auto.
+Qed.
+
+Lemma MapsTo_iff : forall m x y e, E.eq x y -> (MapsTo x e m <-> MapsTo y e m).
+Proof.
+split; apply MapsTo_1; auto.
+Qed.
+
+Lemma mem_in_iff : forall m x, In x m <-> mem x m = true.
+Proof.
+split; [apply mem_1|apply mem_2].
+Qed.
+
+Lemma not_mem_in_iff : forall m x, ~In x m <-> mem x m = false.
+Proof.
+intros; rewrite mem_in_iff; destruct (mem x m); intuition.
+Qed.
+
+Lemma In_dec : forall m x, { In x m } + { ~ In x m }.
+Proof.
+ intros.
+ generalize (mem_in_iff m x).
+ destruct (mem x m); [left|right]; intuition.
+Qed.
+
+Lemma find_mapsto_iff : forall m x e, MapsTo x e m <-> find x m = Some e.
+Proof.
+split; [apply find_1|apply find_2].
+Qed.
+
+Lemma not_find_in_iff : forall m x, ~In x m <-> find x m = None.
+Proof.
+split; intros.
+rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff.
+split; try discriminate. intro H'; elim H; exists e; auto.
+intros (e,He); rewrite find_mapsto_iff,H in He; discriminate.
+Qed.
+
+Lemma in_find_iff : forall m x, In x m <-> find x m <> None.
+Proof.
+intros; rewrite <- not_find_in_iff, mem_in_iff.
+destruct mem; intuition.
+Qed.
+
+Lemma equal_iff : forall m m' cmp, Equivb cmp m m' <-> equal cmp m m' = true.
+Proof.
+split; [apply equal_1|apply equal_2].
+Qed.
+
+Lemma empty_mapsto_iff : forall x e, MapsTo x e (empty elt) <-> False.
+Proof.
+intuition; apply (empty_1 H).
+Qed.
+
+Lemma empty_in_iff : forall x, In x (empty elt) <-> False.
+Proof.
+unfold In.
+split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition.
+Qed.
+
+Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true.
+Proof.
+split; [apply is_empty_1|apply is_empty_2].
+Qed.
+
+Lemma add_mapsto_iff : forall m x y e e',
+  MapsTo y e' (add x e m) <->
+     (E.eq x y /\ e=e') \/
+     (~E.eq x y /\ MapsTo y e' m).
+Proof.
+intros.
+intuition.
+destruct (eq_dec x y); [left|right].
+split; auto.
+symmetry; apply (MapsTo_fun (e':=e) H); auto with map.
+split; auto; apply add_3 with x e; auto.
+subst; auto with map.
+Qed.
+
+Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m.
+Proof.
+unfold In; split.
+intros (e',H).
+destruct (eq_dec x y) as [E|E]; auto.
+right; exists e'; auto.
+apply (add_3 E H).
+destruct (eq_dec x y) as [E|E]; auto.
+intros.
+exists e; apply add_1; auto.
+intros [H|(e',H)].
+destruct E; auto.
+exists e'; apply add_2; auto.
+Qed.
+
+Lemma add_neq_mapsto_iff : forall m x y e e',
+ ~ E.eq x y -> (MapsTo y e' (add x e m)  <-> MapsTo y e' m).
+Proof.
+split; [apply add_3|apply add_2]; auto.
+Qed.
+
+Lemma add_neq_in_iff : forall m x y e,
+ ~ E.eq x y -> (In y (add x e m)  <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+apply (add_3 H H0).
+apply add_2; auto.
+Qed.
+
+Lemma remove_mapsto_iff : forall m x y e,
+  MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m.
+Proof.
+intros.
+split; intros.
+split.
+assert (In y (remove x m)) by (exists e; auto).
+intro H1; apply (remove_1 H1 H0).
+apply remove_3 with x; auto.
+apply remove_2; intuition.
+Qed.
+
+Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m.
+Proof.
+unfold In; split.
+intros (e,H).
+split.
+assert (In y (remove x m)) by (exists e; auto).
+intro H1; apply (remove_1 H1 H0).
+exists e; apply remove_3 with x; auto.
+intros (H,(e,H0)); exists e; apply remove_2; auto.
+Qed.
+
+Lemma remove_neq_mapsto_iff : forall m x y e,
+ ~ E.eq x y -> (MapsTo y e (remove x m)  <-> MapsTo y e m).
+Proof.
+split; [apply remove_3|apply remove_2]; auto.
+Qed.
+
+Lemma remove_neq_in_iff : forall m x y,
+ ~ E.eq x y -> (In y (remove x m)  <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+apply (remove_3 H0).
+apply remove_2; auto.
+Qed.
+
+Lemma elements_mapsto_iff : forall m x e,
+ MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m).
+Proof.
+split; [apply elements_1 | apply elements_2].
+Qed.
+
+Lemma elements_in_iff : forall m x,
+ In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m).
+Proof.
+unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto.
+Qed.
+
+Lemma map_mapsto_iff : forall m x b (f : elt -> elt'),
+ MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m.
+Proof.
+split.
+case_eq (find x m); intros.
+exists e.
+split.
+apply (MapsTo_fun (m:=map f m) (x:=x)); auto with map.
+apply find_2; auto with map.
+assert (In x (map f m)) by (exists b; auto).
+destruct (map_2 H1) as (a,H2).
+rewrite (find_1 H2) in H; discriminate.
+intros (a,(H,H0)).
+subst b; auto with map.
+Qed.
+
+Lemma map_in_iff : forall m x (f : elt -> elt'),
+ In x (map f m) <-> In x m.
+Proof.
+split; intros; eauto with map.
+destruct H as (a,H).
+exists (f a); auto with map.
+Qed.
+
+Lemma mapi_in_iff : forall m x (f:key->elt->elt'),
+ In x (mapi f m) <-> In x m.
+Proof.
+split; intros; eauto with map.
+destruct H as (a,H).
+destruct (mapi_1 f H) as (y,(H0,H1)).
+exists (f y a); auto.
+Qed.
+
+(** Unfortunately, we don't have simple equivalences for [mapi]
+  and [MapsTo]. The only correct one needs compatibility of [f]. *)
+
+Lemma mapi_inv : forall m x b (f : key -> elt -> elt'),
+ MapsTo x b (mapi f m) ->
+ exists a y, E.eq y x /\ b = f y a /\ MapsTo x a m.
+Proof.
+intros; case_eq (find x m); intros.
+exists e.
+destruct (@mapi_1 _ _ m x e f) as (y,(H1,H2)).
+apply find_2; auto with map.
+exists y; repeat split; auto with map.
+apply (MapsTo_fun (m:=mapi f m) (x:=x)); auto with map.
+assert (In x (mapi f m)) by (exists b; auto).
+destruct (mapi_2 H1) as (a,H2).
+rewrite (find_1 H2) in H0; discriminate.
+Qed.
+
+Lemma mapi_1bis : forall m x e (f:key->elt->elt'),
+ (forall x y e, E.eq x y -> f x e = f y e) ->
+ MapsTo x e m -> MapsTo x (f x e) (mapi f m).
+Proof.
+intros.
+destruct (mapi_1 f H0) as (y,(H1,H2)).
+replace (f x e) with (f y e) by auto.
+auto.
+Qed.
+
+Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'),
+ (forall x y e, E.eq x y -> f x e = f y e) ->
+ (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m).
+Proof.
+split.
+intros.
+destruct (mapi_inv H0) as (a,(y,(H1,(H2,H3)))).
+exists a; split; auto.
+subst b; auto.
+intros (a,(H0,H1)).
+subst b.
+apply mapi_1bis; auto.
+Qed.
+
+(** Things are even worse for [map2] : we don't try to state any
+ equivalence, see instead boolean results below. *)
+
+End IffSpec.
+
+(** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *)
+
+Ltac map_iff :=
+ repeat (progress (
+  rewrite add_mapsto_iff || rewrite add_in_iff ||
+  rewrite remove_mapsto_iff || rewrite remove_in_iff ||
+  rewrite empty_mapsto_iff || rewrite empty_in_iff ||
+  rewrite map_mapsto_iff || rewrite map_in_iff ||
+  rewrite mapi_in_iff)).
+
+(** ** Specifications written using boolean predicates *)
+
+Section BoolSpec.
+
+Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false.
+Proof.
+intros.
+generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In.
+destruct (find x m); destruct (mem x m); auto.
+intros.
+rewrite <- H0; exists e; rewrite H; auto.
+intuition.
+destruct H0 as (e,H0).
+destruct (H e); intuition discriminate.
+Qed.
+
+Variable elt elt' elt'' : Type.
+Implicit Types m : t elt.
+Implicit Types x y z : key.
+Implicit Types e : elt.
+
+Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m.
+Proof.
+intros.
+generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H).
+destruct (mem x m); destruct (mem y m); intuition.
+Qed.
+
+Lemma find_o : forall m x y, E.eq x y -> find x m = find y m.
+Proof.
+intros. rewrite eq_option_alt. intro e. rewrite <- 2 find_mapsto_iff.
+apply MapsTo_iff; auto.
+Qed.
+
+Lemma empty_o : forall x, find x (empty elt) = None.
+Proof.
+intros. rewrite eq_option_alt. intro e.
+rewrite <- find_mapsto_iff, empty_mapsto_iff; now intuition.
+Qed.
+
+Lemma empty_a : forall x, mem x (empty elt) = false.
+Proof.
+intros.
+case_eq (mem x (empty elt)); intros; auto.
+generalize (mem_2 H).
+rewrite empty_in_iff; intuition.
+Qed.
+
+Lemma add_eq_o : forall m x y e,
+ E.eq x y -> find y (add x e m) = Some e.
+Proof.
+auto with map.
+Qed.
+
+Lemma add_neq_o : forall m x y e,
+ ~ E.eq x y -> find y (add x e m) = find y m.
+Proof.
+intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff.
+apply add_neq_mapsto_iff; auto.
+Qed.
+Hint Resolve add_neq_o : map.
+
+Lemma add_o : forall m x y e,
+ find y (add x e m) = if eq_dec x y then Some e else find y m.
+Proof.
+intros; destruct (eq_dec x y); auto with map.
+Qed.
+
+Lemma add_eq_b : forall m x y e,
+ E.eq x y -> mem y (add x e m) = true.
+Proof.
+intros; rewrite mem_find_b; rewrite add_eq_o; auto.
+Qed.
+
+Lemma add_neq_b : forall m x y e,
+ ~E.eq x y -> mem y (add x e m) = mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto.
+Qed.
+
+Lemma add_b : forall m x y e,
+ mem y (add x e m) = eqb x y || mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb.
+destruct (eq_dec x y); simpl; auto.
+Qed.
+
+Lemma remove_eq_o : forall m x y,
+ E.eq x y -> find y (remove x m) = None.
+Proof.
+intros. rewrite eq_option_alt. intro e.
+rewrite <- find_mapsto_iff, remove_mapsto_iff; now intuition.
+Qed.
+Hint Resolve remove_eq_o : map.
+
+Lemma remove_neq_o : forall m x y,
+ ~ E.eq x y -> find y (remove x m) = find y m.
+Proof.
+intros. rewrite eq_option_alt. intro e.
+rewrite <- find_mapsto_iff, remove_neq_mapsto_iff; now intuition.
+Qed.
+Hint Resolve remove_neq_o : map.
+
+Lemma remove_o : forall m x y,
+ find y (remove x m) = if eq_dec x y then None else find y m.
+Proof.
+intros; destruct (eq_dec x y); auto with map.
+Qed.
+
+Lemma remove_eq_b : forall m x y,
+ E.eq x y -> mem y (remove x m) = false.
+Proof.
+intros; rewrite mem_find_b; rewrite remove_eq_o; auto.
+Qed.
+
+Lemma remove_neq_b : forall m x y,
+ ~ E.eq x y -> mem y (remove x m) = mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite remove_neq_o; auto.
+Qed.
+
+Lemma remove_b : forall m x y,
+ mem y (remove x m) = negb (eqb x y) && mem y m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb.
+destruct (eq_dec x y); auto.
+Qed.
+
+Lemma map_o : forall m x (f:elt->elt'),
+ find x (map f m) = Datatypes.option_map f (find x m).
+Proof.
+intros.
+generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x)
+  (fun b => map_mapsto_iff m x b f).
+destruct (find x (map f m)); destruct (find x m); simpl; auto; intros.
+rewrite <- H; rewrite H1; exists e0; rewrite H0; auto.
+destruct (H e) as [_ H2].
+rewrite H1 in H2.
+destruct H2 as (a,(_,H2)); auto.
+rewrite H0 in H2; discriminate.
+rewrite <- H; rewrite H1; exists e; rewrite H0; auto.
+Qed.
+
+Lemma map_b : forall m x (f:elt->elt'),
+ mem x (map f m) = mem x m.
+Proof.
+intros; do 2 rewrite mem_find_b; rewrite map_o.
+destruct (find x m); simpl; auto.
+Qed.
+
+Lemma mapi_b : forall m x (f:key->elt->elt'),
+ mem x (mapi f m) = mem x m.
+Proof.
+intros.
+generalize (mem_in_iff (mapi f m) x) (mem_in_iff m x) (mapi_in_iff m x f).
+destruct (mem x (mapi f m)); destruct (mem x m); simpl; auto; intros.
+symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto.
+rewrite <- H; rewrite H1; rewrite H0; auto.
+Qed.
+
+Lemma mapi_o : forall m x (f:key->elt->elt'),
+ (forall x y e, E.eq x y -> f x e = f y e) ->
+ find x (mapi f m) = Datatypes.option_map (f x) (find x m).
+Proof.
+intros.
+generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x)
+  (fun b => mapi_mapsto_iff m x b H).
+destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros.
+rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto.
+destruct (H0 e) as [_ H3].
+rewrite H2 in H3.
+destruct H3 as (a,(_,H3)); auto.
+rewrite H1 in H3; discriminate.
+rewrite <- H0; rewrite H2; exists e; rewrite H1; auto.
+Qed.
+
+Lemma map2_1bis : forall (m: t elt)(m': t elt') x
+ (f:option elt->option elt'->option elt''),
+ f None None = None ->
+ find x (map2 f m m') = f (find x m) (find x m').
+Proof.
+intros.
+case_eq (find x m); intros.
+rewrite <- H0.
+apply map2_1; auto with map.
+left; exists e; auto with map.
+case_eq (find x m'); intros.
+rewrite <- H0; rewrite <- H1.
+apply map2_1; auto.
+right; exists e; auto with map.
+rewrite H.
+case_eq (find x (map2 f m m')); intros; auto with map.
+assert (In x (map2 f m m')) by (exists e; auto with map).
+destruct (map2_2 H3) as [(e0,H4)|(e0,H4)].
+rewrite (find_1 H4) in H0; discriminate.
+rewrite (find_1 H4) in H1; discriminate.
+Qed.
+
+Lemma elements_o : forall m x,
+ find x m = findA (eqb x) (elements m).
+Proof.
+intros. rewrite eq_option_alt. intro e.
+rewrite <- find_mapsto_iff, elements_mapsto_iff.
+unfold eqb.
+rewrite <- findA_NoDupA; dintuition; try apply elements_3w; eauto.
+Qed.
+
+Lemma elements_b : forall m x,
+ mem x m = existsb (fun p => eqb x (fst p)) (elements m).
+Proof.
+intros.
+generalize (mem_in_iff m x)(elements_in_iff m x)
+ (existsb_exists (fun p => eqb x (fst p)) (elements m)).
+destruct (mem x m); destruct (existsb (fun p => eqb x (fst p)) (elements m)); auto; intros.
+symmetry; rewrite H1.
+destruct H0 as (H0,_).
+destruct H0 as (e,He); [ intuition |].
+rewrite InA_alt in He.
+destruct He as ((y,e'),(Ha1,Ha2)).
+compute in Ha1; destruct Ha1; subst e'.
+exists (y,e); split; simpl; auto.
+unfold eqb; destruct (eq_dec x y); intuition.
+rewrite <- H; rewrite H0.
+destruct H1 as (H1,_).
+destruct H1 as ((y,e),(Ha1,Ha2)); [intuition|].
+simpl in Ha2.
+unfold eqb in *; destruct (eq_dec x y); auto; try discriminate.
+exists e; rewrite InA_alt.
+exists (y,e); intuition.
+compute; auto.
+Qed.
+
+End BoolSpec.
+
+Section Equalities.
+
+Variable elt:Type.
+
+ (** Another characterisation of [Equal] *)
+
+Lemma Equal_mapsto_iff : forall m1 m2 : t elt,
+ Equal m1 m2 <-> (forall k e, MapsTo k e m1 <-> MapsTo k e m2).
+Proof.
+intros m1 m2. split; [intros Heq k e|intros Hiff].
+rewrite 2 find_mapsto_iff, Heq. split; auto.
+intro k. rewrite eq_option_alt. intro e.
+rewrite <- 2 find_mapsto_iff; auto.
+Qed.
+
+(** * Relations between [Equal], [Equiv] and [Equivb]. *)
+
+(** First, [Equal] is [Equiv] with Leibniz on elements. *)
+
+Lemma Equal_Equiv : forall (m m' : t elt),
+  Equal m m' <-> Equiv Logic.eq m m'.
+Proof.
+intros. rewrite Equal_mapsto_iff. split; intros.
+split.
+split; intros (e,Hin); exists e; [rewrite <- H|rewrite H]; auto.
+intros; apply MapsTo_fun with m k; auto; rewrite H; auto.
+split; intros H'.
+destruct H.
+assert (Hin : In k m') by (rewrite <- H; exists e; auto).
+destruct Hin as (e',He').
+rewrite (H0 k e e'); auto.
+destruct H.
+assert (Hin : In k m) by (rewrite H; exists e; auto).
+destruct Hin as (e',He').
+rewrite <- (H0 k e' e); auto.
+Qed.
+
+(** [Equivb] and [Equiv] and equivalent when [eq_elt] and [cmp]
+    are related. *)
+
+Section Cmp.
+Variable eq_elt : elt->elt->Prop.
+Variable cmp : elt->elt->bool.
+
+Definition compat_cmp :=
+ forall e e', cmp e e' = true <-> eq_elt e e'.
+
+Lemma Equiv_Equivb : compat_cmp ->
+ forall m m', Equiv eq_elt m m' <-> Equivb cmp m m'.
+Proof.
+ unfold Equivb, Equiv, Cmp; intuition.
+ red in H; rewrite H; eauto.
+ red in H; rewrite <-H; eauto.
+Qed.
+End Cmp.
+
+(** Composition of the two last results: relation between [Equal]
+    and [Equivb]. *)
+
+Lemma Equal_Equivb : forall cmp,
+ (forall e e', cmp e e' = true <-> e = e') ->
+ forall (m m':t elt), Equal m m' <-> Equivb cmp m m'.
+Proof.
+ intros; rewrite Equal_Equiv.
+ apply Equiv_Equivb; auto.
+Qed.
+
+Lemma Equal_Equivb_eqdec :
+ forall eq_elt_dec : (forall e e', { e = e' } + { e <> e' }),
+ let cmp := fun e e' => if eq_elt_dec e e' then true else false in
+ forall (m m':t elt), Equal m m' <-> Equivb cmp m m'.
+Proof.
+intros; apply Equal_Equivb.
+unfold cmp; clear cmp; intros.
+destruct eq_elt_dec; now intuition.
+Qed.
+
+End Equalities.
+
+(** * [Equal] is a setoid equality. *)
+
+Lemma Equal_refl : forall (elt:Type)(m : t elt), Equal m m.
+Proof. red; reflexivity. Qed.
+
+Lemma Equal_sym : forall (elt:Type)(m m' : t elt),
+ Equal m m' -> Equal m' m.
+Proof. unfold Equal; auto. Qed.
+
+Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt),
+ Equal m m' -> Equal m' m'' -> Equal m m''.
+Proof. unfold Equal; congruence. Qed.
+
+Definition Equal_ST : forall elt:Type, Equivalence (@Equal elt).
+Proof.
+constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans].
+Qed.
+
+Add Relation key E.eq
+ reflexivity proved by E.eq_refl
+ symmetry proved by E.eq_sym
+ transitivity proved by E.eq_trans
+ as KeySetoid.
+
+Arguments Equal {elt} m m'.
+
+Add Parametric Relation (elt : Type) : (t elt) Equal
+ reflexivity proved by (@Equal_refl elt)
+ symmetry proved by (@Equal_sym elt)
+ transitivity proved by (@Equal_trans elt)
+ as EqualSetoid.
+
+Add Parametric Morphism elt : (@In elt)
+ with signature E.eq ==> Equal ==> iff as In_m.
+Proof.
+unfold Equal; intros k k' Hk m m' Hm.
+rewrite (In_iff m Hk), in_find_iff, in_find_iff, Hm; intuition.
+Qed.
+
+Add Parametric Morphism elt : (@MapsTo elt)
+ with signature E.eq ==> eq ==> Equal ==> iff as MapsTo_m.
+Proof.
+unfold Equal; intros k k' Hk e m m' Hm.
+rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm;
+ intuition.
+Qed.
+
+Add Parametric Morphism elt : (@Empty elt)
+ with signature Equal ==> iff as Empty_m.
+Proof.
+unfold Empty; intros m m' Hm. split; intros; intro.
+rewrite <-Hm in H0; eapply H, H0.
+rewrite Hm in H0; eapply H, H0.
+Qed.
+
+Add Parametric Morphism elt : (@is_empty elt)
+ with signature Equal ==> eq as is_empty_m.
+Proof.
+intros m m' Hm.
+rewrite eq_bool_alt, <-is_empty_iff, <-is_empty_iff, Hm; intuition.
+Qed.
+
+Add Parametric Morphism elt : (@mem elt)
+ with signature E.eq ==> Equal ==> eq as mem_m.
+Proof.
+intros k k' Hk m m' Hm.
+rewrite eq_bool_alt, <- mem_in_iff, <-mem_in_iff, Hk, Hm; intuition.
+Qed.
+
+Add Parametric Morphism elt : (@find elt)
+ with signature E.eq ==> Equal ==> eq as find_m.
+Proof.
+intros k k' Hk m m' Hm. rewrite eq_option_alt. intro e.
+rewrite <- 2 find_mapsto_iff, Hk, Hm. split; auto.
+Qed.
+
+Add Parametric Morphism elt : (@add elt)
+ with signature E.eq ==> eq ==> Equal ==> Equal as add_m.
+Proof.
+intros k k' Hk e m m' Hm y.
+rewrite add_o, add_o; do 2 destruct eq_dec as [|?Hnot]; auto.
+elim Hnot; rewrite <-Hk; auto.
+elim Hnot; rewrite Hk; auto.
+Qed.
+
+Add Parametric Morphism elt : (@remove elt)
+ with signature E.eq ==> Equal ==> Equal as remove_m.
+Proof.
+intros k k' Hk m m' Hm y.
+rewrite remove_o, remove_o; do 2 destruct eq_dec as [|?Hnot]; auto.
+elim Hnot; rewrite <-Hk; auto.
+elim Hnot; rewrite Hk; auto.
+Qed.
+
+Add Parametric Morphism elt elt' : (@map elt elt')
+ with signature eq ==> Equal ==> Equal as map_m.
+Proof.
+intros f m m' Hm y.
+rewrite map_o, map_o, Hm; auto.
+Qed.
+
+(* Later: Add Morphism cardinal *)
+
+(* old name: *)
+Notation not_find_mapsto_iff := not_find_in_iff.
+
+End WFacts_fun.
+
+(** * Same facts for self-contained weak sets and for full maps *)
+
+Module WFacts (M:WS) := WFacts_fun M.E M.
+Module Facts := WFacts.
+
+(** * Additional Properties for weak maps
+
+    Results about [fold], [elements], induction principles...
+*)
+
+Module WProperties_fun (E:DecidableType)(M:WSfun E).
+ Module Import F:=WFacts_fun E M.
+ Import M.
+
+ Section Elt.
+  Variable elt:Type.
+
+  Definition Add x (e:elt) m m' := forall y, find y m' = find y (add x e m).
+
+  Notation eqke := (@eq_key_elt elt).
+  Notation eqk := (@eq_key elt).
+
+  Instance eqk_equiv : Equivalence eqk.
+  Proof. unfold eq_key; split; eauto. Qed.
+
+  Instance eqke_equiv : Equivalence eqke.
+  Proof.
+   unfold eq_key_elt; split; repeat red; firstorder.
+   eauto with *.
+   congruence.
+  Qed.
+
+  (** Complements about InA, NoDupA and findA *)
+
+  Lemma InA_eqke_eqk : forall k1 k2 e1 e2 l,
+    E.eq k1 k2 -> InA eqke (k1,e1) l -> InA eqk (k2,e2) l.
+  Proof.
+  intros k1 k2 e1 e2 l Hk. rewrite 2 InA_alt.
+  intros ((k',e') & (Hk',He') & H); simpl in *.
+  exists (k',e'); split; auto.
+  red; simpl; eauto.
+  Qed.
+
+  Lemma NoDupA_eqk_eqke : forall l, NoDupA eqk l -> NoDupA eqke l.
+  Proof.
+  induction 1; auto.
+  constructor; auto.
+  destruct x as (k,e).
+  eauto using InA_eqke_eqk.
+  Qed.
+
+  Lemma findA_rev : forall l k, NoDupA eqk l ->
+    findA (eqb k) l = findA (eqb k) (rev l).
+  Proof.
+  intros.
+  case_eq (findA (eqb k) l).
+  intros. symmetry.
+  unfold eqb.
+  rewrite <- findA_NoDupA, InA_rev, findA_NoDupA
+   by (eauto using NoDupA_rev with *); eauto.
+  case_eq (findA (eqb k) (rev l)); auto.
+  intros e.
+  unfold eqb.
+  rewrite <- findA_NoDupA, InA_rev, findA_NoDupA
+   by (eauto using NoDupA_rev with *).
+  intro Eq; rewrite Eq; auto.
+  Qed.
+
+  (** * Elements *)
+
+  Lemma elements_Empty : forall m:t elt, Empty m <-> elements m = nil.
+  Proof.
+  intros.
+  unfold Empty.
+  split; intros.
+  assert (forall a, ~ List.In a (elements m)).
+   red; intros.
+   apply (H (fst a) (snd a)).
+   rewrite elements_mapsto_iff.
+   rewrite InA_alt; exists a; auto.
+   split; auto; split; auto.
+  destruct (elements m); auto.
+  elim (H0 p); simpl; auto.
+  red; intros.
+  rewrite elements_mapsto_iff in H0.
+  rewrite InA_alt in H0; destruct H0.
+  rewrite H in H0; destruct H0 as (_,H0); inversion H0.
+  Qed.
+
+  Lemma elements_empty : elements (@empty elt) = nil.
+  Proof.
+  rewrite <-elements_Empty; apply empty_1.
+  Qed.
+
+  (** * Conversions between maps and association lists. *)
+
+  Definition uncurry {U V W : Type} (f : U -> V -> W) : U*V -> W :=
+   fun p => f (fst p) (snd p).
+
+  Definition of_list :=
+    List.fold_right (uncurry (@add _)) (empty elt).
+
+  Definition to_list := elements.
+
+  Lemma of_list_1 : forall l k e,
+    NoDupA eqk l ->
+    (MapsTo k e (of_list l) <-> InA eqke (k,e) l).
+  Proof.
+  induction l as [|(k',e') l IH]; simpl; intros k e Hnodup.
+  rewrite empty_mapsto_iff, InA_nil; intuition.
+  unfold uncurry; simpl.
+  inversion_clear Hnodup as [| ? ? Hnotin Hnodup'].
+  specialize (IH k e Hnodup'); clear Hnodup'.
+  rewrite add_mapsto_iff, InA_cons, <- IH.
+  unfold eq_key_elt at 1; simpl.
+  split; destruct 1 as [H|H]; try (intuition;fail).
+  destruct (eq_dec k k'); [left|right]; split; auto.
+  contradict Hnotin.
+  apply InA_eqke_eqk with k e; intuition.
+  Qed.
+
+  Lemma of_list_1b : forall l k,
+    NoDupA eqk l ->
+    find k (of_list l) = findA (eqb k) l.
+  Proof.
+  induction l as [|(k',e') l IH]; simpl; intros k Hnodup.
+  apply empty_o.
+  unfold uncurry; simpl.
+  inversion_clear Hnodup as [| ? ? Hnotin Hnodup'].
+  specialize (IH k Hnodup'); clear Hnodup'.
+  rewrite add_o, IH.
+  unfold eqb; do 2 destruct eq_dec as [|?Hnot]; auto; elim Hnot; eauto.
+  Qed.
+
+  Lemma of_list_2 : forall l, NoDupA eqk l ->
+    equivlistA eqke l (to_list (of_list l)).
+  Proof.
+  intros l Hnodup (k,e).
+  rewrite <- elements_mapsto_iff, of_list_1; intuition.
+  Qed.
+
+  Lemma of_list_3 : forall s, Equal (of_list (to_list s)) s.
+  Proof.
+  intros s k.
+  rewrite of_list_1b, elements_o; auto.
+  apply elements_3w.
+  Qed.
+
+  (** * Fold *)
+
+  (** Alternative specification via [fold_right] *)
+
+  Lemma fold_spec_right m (A:Type)(i:A)(f : key -> elt -> A -> A) :
+    fold f m i = List.fold_right (uncurry f) i (rev (elements m)).
+  Proof.
+   rewrite fold_1. symmetry. apply fold_left_rev_right.
+  Qed.
+
+  (** ** Induction principles about fold contributed by S. Lescuyer *)
+
+  (** In the following lemma, the step hypothesis is deliberately restricted
+      to the precise map m we are considering. *)
+
+  Lemma fold_rec :
+    forall (A:Type)(P : t elt -> A -> Type)(f : key -> elt -> A -> A),
+     forall (i:A)(m:t elt),
+      (forall m, Empty m -> P m i) ->
+      (forall k e a m' m'', MapsTo k e m -> ~In k m' ->
+         Add k e m' m'' -> P m' a -> P m'' (f k e a)) ->
+      P m (fold f m i).
+  Proof.
+  intros A P f i m Hempty Hstep.
+  rewrite fold_spec_right.
+  set (F:=uncurry f).
+  set (l:=rev (elements m)).
+  assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' ->
+             Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)).
+   intros k e a m' m'' H ? ? ?; eapply Hstep; eauto.
+   revert H; unfold l; rewrite InA_rev, elements_mapsto_iff; auto with *.
+  assert (Hdup : NoDupA eqk l).
+   unfold l. apply NoDupA_rev; try red; unfold eq_key ; eauto with *.
+   apply elements_3w.
+  assert (Hsame : forall k, find k m = findA (eqb k) l).
+   intros k. unfold l. rewrite elements_o, findA_rev; auto.
+   apply elements_3w.
+  clearbody l. clearbody F. clear Hstep f. revert m Hsame. induction l.
+  (* empty *)
+  intros m Hsame; simpl.
+  apply Hempty. intros k e.
+  rewrite find_mapsto_iff, Hsame; simpl; discriminate.
+  (* step *)
+  intros m Hsame; destruct a as (k,e); simpl.
+  apply Hstep' with (of_list l); auto.
+   rewrite InA_cons; left; red; auto.
+   inversion_clear Hdup. contradict H. destruct H as (e',He').
+   apply InA_eqke_eqk with k e'; auto.
+   rewrite <- of_list_1; auto.
+   intro k'. rewrite Hsame, add_o, of_list_1b. simpl.
+   unfold eqb. do 2 destruct eq_dec as [|?Hnot]; auto; elim Hnot; eauto.
+   inversion_clear Hdup; auto.
+  apply IHl.
+   intros; eapply Hstep'; eauto.
+   inversion_clear Hdup; auto.
+   intros; apply of_list_1b. inversion_clear Hdup; auto.
+  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 elt -> A -> Type)(f : key -> elt -> A -> A),
+     forall (i:A)(m:t elt),
+     (forall m m' a, Equal m m' -> P m a -> P m' a) ->
+     (P (empty _) i) ->
+     (forall k e a m', MapsTo k e m -> ~In k m' ->
+       P m' a -> P (add k e m') (f k e a)) ->
+     P m (fold f m i).
+  Proof.
+  intros A P f i m Pmorphism Pempty Pstep.
+  apply fold_rec; intros.
+  apply Pmorphism with (empty _); auto. intro k. rewrite empty_o.
+  case_eq (find k m0); auto; intros e'; rewrite <- find_mapsto_iff.
+  intro H'; elim (H k e'); auto.
+  apply Pmorphism with (add k e m'); try intro; auto.
+  Qed.
+
+  Lemma fold_rec_nodep :
+    forall (A:Type)(P : A -> Type)(f : key -> elt -> A -> A)(i:A)(m:t elt),
+     P i -> (forall k e a, MapsTo k e m -> P a -> P (f k e a)) ->
+     P (fold f m 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 anywhere.
+      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 elt -> A -> Type)(f : key -> elt -> A -> A)(i:A),
+    (forall m m' a, Equal m m' -> P m a -> P m' a) ->
+    P (empty _) i ->
+    (forall k e a m, ~In k m -> P m a -> P (add k e m) (f k e a)) ->
+    forall m, P m (fold f m i).
+  Proof.
+  intros; apply fold_rec_bis; auto.
+  Qed.
+
+  Lemma fold_rel :
+    forall (A B:Type)(R : A -> B -> Type)
+     (f : key -> elt -> A -> A)(g : key -> elt -> B -> B)(i : A)(j : B)
+     (m : t elt),
+     R i j ->
+     (forall k e a b, MapsTo k e m -> R a b -> R (f k e a) (g k e b)) ->
+     R (fold f m i) (fold g m j).
+  Proof.
+  intros A B R f g i j m Rempty Rstep.
+  rewrite 2 fold_spec_right. set (l:=rev (elements m)).
+  assert (Rstep' : forall k e a b, InA eqke (k,e) l ->
+    R a b -> R (f k e a) (g k e b)) by
+    (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; auto with *).
+  clearbody l; clear Rstep m.
+  induction l; simpl; auto.
+  apply Rstep'; auto.
+  destruct a; simpl; rewrite InA_cons; left; red; auto.
+  Qed.
+
+  (** From the induction principle on [fold], we can deduce some general
+      induction principles on maps. *)
+
+  Lemma map_induction :
+   forall P : t elt -> Type,
+   (forall m, Empty m -> P m) ->
+   (forall m m', P m -> forall x e, ~In x m -> Add x e m m' -> P m') ->
+   forall m, P m.
+  Proof.
+  intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto.
+  Qed.
+
+  Lemma map_induction_bis :
+   forall P : t elt -> Type,
+   (forall m m', Equal m m' -> P m -> P m') ->
+   P (empty _) ->
+   (forall x e m, ~In x m -> P m -> P (add x e m)) ->
+   forall m, P m.
+  Proof.
+  intros.
+  apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ _ => tt) tt m); eauto.
+  Qed.
+
+  (** [fold] can be used to reconstruct the same initial set. *)
+
+  Lemma fold_identity : forall m : t elt, Equal (fold (@add _) m (empty _)) m.
+  Proof.
+  intros.
+  apply fold_rec with (P:=fun m acc => Equal acc m); auto with map.
+  intros m' Heq k'.
+  rewrite empty_o.
+  case_eq (find k' m'); auto; intros e'; rewrite <- find_mapsto_iff.
+  intro; elim (Heq k' e'); auto.
+  intros k e a m' m'' _ _ Hadd Heq k'.
+  red in Heq. rewrite Hadd, 2 add_o, Heq; auto.
+  Qed.
+
+  Section Fold_More.
+
+  (** ** Additional properties of fold *)
+
+  (** When a function [f] is compatible and allows transpositions, we can
+      compute [fold f] in any order. *)
+
+  Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A).
+
+  (** This is more convenient than a [compat_op eqke ...].
+      In fact, every [compat_op], [compat_bool], etc, should
+      become a [Proper] someday. *)
+  Hypothesis Comp : Proper (E.eq==>eq==>eqA==>eqA) f.
+
+  Lemma fold_init :
+   forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i').
+  Proof.
+  intros. apply fold_rel with (R:=eqA); auto.
+  intros. apply Comp; auto.
+  Qed.
+
+  Lemma fold_Empty :
+   forall m i, Empty m -> eqA (fold f m i) i.
+  Proof.
+  intros. apply fold_rec_nodep with (P:=fun a => eqA a i).
+  reflexivity.
+  intros. elim (H k e); auto.
+  Qed.
+
+  (** As noticed by P. Casteran, asking for the general [SetoidList.transpose]
+      here is too restrictive. Think for instance of [f] being [M.add] :
+      in general, [M.add k e (M.add k e' m)] is not equivalent to
+      [M.add k e' (M.add k e m)]. Fortunately, we will never encounter this
+      situation during a real [fold], since the keys received by this [fold]
+      are unique. Hence we can ask the transposition property to hold only
+      for non-equal keys.
+
+      This idea could be push slightly further, by asking the transposition
+      property to hold only for (non-equal) keys living in the map given to
+      [fold]. Please contact us if you need such a version.
+
+      FSets could also benefit from a restricted [transpose], but for this
+      case the gain is unclear. *)
+
+  Definition transpose_neqkey :=
+    forall k k' e e' a, ~E.eq k k' ->
+      eqA (f k e (f k' e' a)) (f k' e' (f k e a)).
+
+  Hypothesis Tra : transpose_neqkey.
+
+  Lemma fold_commutes : forall i m k e, ~In k m ->
+   eqA (fold f m (f k e i)) (f k e (fold f m i)).
+  Proof.
+  intros i m k e Hnotin.
+  apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto.
+  reflexivity.
+  intros.
+  transitivity (f k0 e0 (f k e b)).
+  apply Comp; auto.
+  apply Tra; auto.
+  contradict Hnotin; rewrite <- Hnotin; exists e0; auto.
+  Qed.
+
+  Hint Resolve NoDupA_eqk_eqke NoDupA_rev elements_3w : map.
+
+  Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 ->
+   eqA (fold f m1 i) (fold f m2 i).
+  Proof.
+  intros.
+  rewrite 2 fold_spec_right.
+  assert (NoDupA eqk (rev (elements m1))) by (auto with *).
+  assert (NoDupA eqk (rev (elements m2))) by (auto with *).
+  apply fold_right_equivlistA_restr with (R:=complement eqk)(eqA:=eqke);
+   auto with *.
+  intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto.
+  unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto.
+  intros (k,e) (k',e'); unfold eq_key, uncurry; simpl; auto.
+  rewrite <- NoDupA_altdef; auto.
+  intros (k,e).
+  rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H;
+   auto with *.
+  Qed.
+
+  Lemma fold_Equal2 : forall m1 m2 i j, Equal m1 m2 -> eqA i j ->
+    eqA (fold f m1 i) (fold f m2 j).
+  Proof.
+  intros.
+  rewrite 2 fold_spec_right.
+  assert (NoDupA eqk (rev (elements m1))) by (auto with * ).
+  assert (NoDupA eqk (rev (elements m2))) by (auto with * ).
+  apply fold_right_equivlistA_restr2 with (R:=complement eqk)(eqA:=eqke)
+  ; auto with *.
+  - intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto.
+  - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto.
+  - intros (k,e) (k',e') z z' h h'; unfold eq_key, uncurry;simpl; auto.
+    rewrite h'.
+    auto.
+  - rewrite <- NoDupA_altdef; auto.
+  - intros (k,e).
+    rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H;
+      auto with *.
+  Qed.
+
+
+  Lemma fold_Add : forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 ->
+   eqA (fold f m2 i) (f k e (fold f m1 i)).
+  Proof.
+  intros.
+  rewrite 2 fold_spec_right.
+  set (f':=uncurry f).
+  change (f k e (fold_right f' i (rev (elements m1))))
+   with (f' (k,e) (fold_right f' i (rev (elements m1)))).
+  assert (NoDupA eqk (rev (elements m1))) by (auto with *).
+  assert (NoDupA eqk (rev (elements m2))) by (auto with *).
+  apply fold_right_add_restr with
+   (R:=complement eqk)(eqA:=eqke)(eqB:=eqA); auto with *.
+  intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. apply Comp; auto.
+  unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto.
+  unfold f'; intros (k1,e1) (k2,e2); unfold eq_key, uncurry; simpl; auto.
+  rewrite <- NoDupA_altdef; auto.
+  rewrite InA_rev, <- elements_mapsto_iff by (auto with *). firstorder.
+  intros (a,b).
+  rewrite InA_cons, 2 InA_rev, <- 2 elements_mapsto_iff,
+   2 find_mapsto_iff by (auto with *).
+  unfold eq_key_elt; simpl.
+  rewrite H0.
+  rewrite add_o.
+  destruct (eq_dec k a) as [EQ|NEQ]; split; auto.
+  intros EQ'; inversion EQ'; auto.
+  intuition; subst; auto.
+  elim H. exists b; rewrite EQ; auto with map.
+  intuition.
+  elim NEQ; auto.
+  Qed.
+
+  Lemma fold_add : forall m k e i, ~In k m ->
+   eqA (fold f (add k e m) i) (f k e (fold f m i)).
+  Proof.
+  intros. apply fold_Add; try red; auto.
+  Qed.
+
+  End Fold_More.
+
+  (** * Cardinal *)
+
+  Lemma cardinal_fold : forall m : t elt,
+   cardinal m = fold (fun _ _ => S) m 0.
+  Proof.
+  intros; rewrite cardinal_1, fold_1.
+  symmetry; apply fold_left_length; auto.
+  Qed.
+
+  Lemma cardinal_Empty : forall m : t elt,
+   Empty m <-> cardinal m = 0.
+  Proof.
+  intros.
+  rewrite cardinal_1, elements_Empty.
+  destruct (elements m); intuition; discriminate.
+  Qed.
+
+  Lemma Equal_cardinal : forall m m' : t elt,
+    Equal m m' -> cardinal m = cardinal m'.
+  Proof.
+  intros; do 2 rewrite cardinal_fold.
+  apply fold_Equal with (eqA:=eq); compute; auto.
+  Qed.
+
+  Lemma cardinal_1 : forall m : t elt, Empty m -> cardinal m = 0.
+  Proof.
+  intros; rewrite <- cardinal_Empty; auto.
+  Qed.
+
+  Lemma cardinal_2 :
+    forall m m' x e, ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m).
+  Proof.
+  intros; do 2 rewrite cardinal_fold.
+  change S with ((fun _ _ => S) x e).
+  apply fold_Add with (eqA:=eq); compute; auto.
+  Qed.
+
+  Lemma cardinal_inv_1 : forall m : t elt,
+   cardinal m = 0 -> Empty m.
+  Proof.
+  intros; rewrite cardinal_Empty; auto.
+  Qed.
+  Hint Resolve cardinal_inv_1 : map.
+
+  Lemma cardinal_inv_2 :
+   forall m n, cardinal m = S n -> { p : key*elt | MapsTo (fst p) (snd p) m }.
+  Proof.
+  intros; rewrite M.cardinal_1 in *.
+  generalize (elements_mapsto_iff m).
+  destruct (elements m); try discriminate.
+  exists p; auto.
+  rewrite H0; destruct p; simpl; auto.
+  constructor; red; auto.
+  Qed.
+
+  Lemma cardinal_inv_2b :
+   forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }.
+  Proof.
+  intros.
+  generalize (@cardinal_inv_2 m); destruct cardinal.
+  elim H;auto.
+  eauto.
+  Qed.
+
+  (** * Additional notions over maps *)
+
+  Definition Disjoint (m m' : t elt) :=
+   forall k, ~(In k m /\ In k m').
+
+  Definition Partition (m m1 m2 : t elt) :=
+    Disjoint m1 m2 /\
+    (forall k e, MapsTo k e m <-> MapsTo k e m1 \/ MapsTo k e m2).
+
+  (** * Emulation of some functions lacking in the interface *)
+
+  Definition filter (f : key -> elt -> bool)(m : t elt) :=
+   fold (fun k e m => if f k e then add k e m else m) m (empty _).
+
+  Definition for_all (f : key -> elt -> bool)(m : t elt) :=
+   fold (fun k e b => if f k e then b else false) m true.
+
+  Definition exists_ (f : key -> elt -> bool)(m : t elt) :=
+   fold (fun k e b => if f k e then true else b) m false.
+
+  Definition partition (f : key -> elt -> bool)(m : t elt) :=
+   (filter f m, filter (fun k e => negb (f k e)) m).
+
+  (** [update] adds to [m1] all the bindings of [m2]. It can be seen as
+     an [union] operator which gives priority to its 2nd argument
+     in case of binding conflit. *)
+
+  Definition update (m1 m2 : t elt) := fold (@add _) m2 m1.
+
+  (** [restrict] keeps from [m1] only the bindings whose key is in [m2].
+      It can be seen as an [inter] operator, with priority to its 1st argument
+      in case of binding conflit. *)
+
+  Definition restrict (m1 m2 : t elt) := filter (fun k _ => mem k m2) m1.
+
+  (** [diff] erases from [m1] all bindings whose key is in [m2]. *)
+
+  Definition diff (m1 m2 : t elt) := filter (fun k _ => negb (mem k m2)) m1.
+
+  Section Specs.
+  Variable f : key -> elt -> bool.
+  Hypothesis Hf : Proper (E.eq==>eq==>eq) f.
+
+  Lemma filter_iff : forall m k e,
+   MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true.
+  Proof.
+  unfold filter.
+  set (f':=fun k e m => if f k e then add k e m else m).
+  intro m. pattern m, (fold f' m (empty _)). apply fold_rec.
+
+  intros m' Hm' k e. rewrite empty_mapsto_iff. intuition.
+  elim (Hm' k e); auto.
+
+  intros k e acc m1 m2 Hke Hn Hadd IH k' e'.
+  change (Equal m2 (add k e m1)) in Hadd; rewrite Hadd.
+  unfold f'; simpl.
+  case_eq (f k e); intros Hfke; simpl;
+   rewrite !add_mapsto_iff, IH; clear IH; intuition.
+  rewrite <- Hfke; apply Hf; auto.
+  destruct (eq_dec k k') as [Hk|Hk]; [left|right]; auto.
+  elim Hn; exists e'; rewrite Hk; auto.
+  assert (f k e = f k' e') by (apply Hf; auto). congruence.
+  Qed.
+
+  Lemma for_all_iff : forall m,
+   for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true).
+  Proof.
+  unfold for_all.
+  set (f':=fun k e b => if f k e then b else false).
+  intro m. pattern m, (fold f' m true). apply fold_rec.
+
+  intros m' Hm'. split; auto. intros _ k e Hke. elim (Hm' k e); auto.
+
+  intros k e b m1 m2 _ Hn Hadd IH. clear m.
+  change (Equal m2 (add k e m1)) in Hadd.
+  unfold f'; simpl. case_eq (f k e); intros Hfke.
+  (* f k e = true *)
+  rewrite IH. clear IH. split; intros Hmapsto k' e' Hke'.
+  rewrite Hadd, add_mapsto_iff in Hke'.
+  destruct Hke' as [(?,?)|(?,?)]; auto.
+  rewrite <- Hfke; apply Hf; auto.
+  apply Hmapsto. rewrite Hadd, add_mapsto_iff; right; split; auto.
+  contradict Hn; exists e'; rewrite Hn; auto.
+  (* f k e = false *)
+  split; try discriminate.
+  intros Hmapsto. rewrite <- Hfke. apply Hmapsto.
+  rewrite Hadd, add_mapsto_iff; auto.
+  Qed.
+
+  Lemma exists_iff : forall m,
+   exists_ f m = true <->
+   (exists p, MapsTo (fst p) (snd p) m /\ f (fst p) (snd p) = true).
+  Proof.
+  unfold exists_.
+  set (f':=fun k e b => if f k e then true else b).
+  intro m. pattern m, (fold f' m false). apply fold_rec.
+
+  intros m' Hm'. split; try discriminate.
+  intros ((k,e),(Hke,_)); simpl in *. elim (Hm' k e); auto.
+
+  intros k e b m1 m2 _ Hn Hadd IH. clear m.
+  change (Equal m2 (add k e m1)) in Hadd.
+  unfold f'; simpl. case_eq (f k e); intros Hfke.
+  (* f k e = true *)
+  split; [intros _|auto].
+  exists (k,e); simpl; split; auto.
+  rewrite Hadd, add_mapsto_iff; auto.
+  (* f k e = false *)
+  rewrite IH. clear IH. split; intros ((k',e'),(Hke1,Hke2)); simpl in *.
+  exists (k',e'); simpl; split; auto.
+  rewrite Hadd, add_mapsto_iff; right; split; auto.
+  contradict Hn. exists e'; rewrite Hn; auto.
+  rewrite Hadd, add_mapsto_iff in Hke1. destruct Hke1 as [(?,?)|(?,?)].
+  assert (f k' e' = f k e) by (apply Hf; auto). congruence.
+  exists (k',e'); auto.
+  Qed.
+
+  End Specs.
+
+  Lemma Disjoint_alt : forall m m',
+   Disjoint m m' <->
+   (forall k e e', MapsTo k e m -> MapsTo k e' m' -> False).
+  Proof.
+  unfold Disjoint; split.
+  intros H k v v' H1 H2.
+  apply H with k; split.
+  exists v; trivial.
+  exists v'; trivial.
+  intros H k ((v,Hv),(v',Hv')).
+  eapply H; eauto.
+  Qed.
+
+  Section Partition.
+  Variable f : key -> elt -> bool.
+  Hypothesis Hf : Proper (E.eq==>eq==>eq) f.
+
+  Lemma partition_iff_1 : forall m m1 k e,
+   m1 = fst (partition f m) ->
+   (MapsTo k e m1 <-> MapsTo k e m /\ f k e = true).
+  Proof.
+  unfold partition; simpl; intros. subst m1.
+  apply filter_iff; auto.
+  Qed.
+
+  Lemma partition_iff_2 : forall m m2 k e,
+   m2 = snd (partition f m) ->
+   (MapsTo k e m2 <-> MapsTo k e m /\ f k e = false).
+  Proof.
+  unfold partition; simpl; intros. subst m2.
+  rewrite filter_iff.
+  split; intros (H,H'); split; auto.
+  destruct (f k e); simpl in *; auto.
+  rewrite H'; auto.
+  repeat red; intros. f_equal. apply Hf; auto.
+  Qed.
+
+  Lemma partition_Partition : forall m m1 m2,
+   partition f m = (m1,m2) -> Partition m m1 m2.
+  Proof.
+  intros. split.
+  rewrite Disjoint_alt. intros k e e'.
+  rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2)
+   by (rewrite H; auto).
+  intros (U,V) (W,Z). rewrite <- (MapsTo_fun U W) in Z; congruence.
+  intros k e.
+  rewrite (@partition_iff_1 m m1), (@partition_iff_2 m m2)
+   by (rewrite H; auto).
+  destruct (f k e); intuition.
+  Qed.
+
+  End Partition.
+
+  Lemma Partition_In : forall m m1 m2 k,
+   Partition m m1 m2 -> In k m -> {In k m1}+{In k m2}.
+  Proof.
+  intros m m1 m2 k Hm Hk.
+  destruct (In_dec m1 k) as [H|H]; [left|right]; auto.
+  destruct Hm as (Hm,Hm').
+  destruct Hk as (e,He); rewrite Hm' in He; destruct He.
+  elim H; exists e; auto.
+  exists e; auto.
+  Defined.
+
+  Lemma Disjoint_sym : forall m1 m2, Disjoint m1 m2 -> Disjoint m2 m1.
+  Proof.
+  intros m1 m2 H k (H1,H2). elim (H k); auto.
+  Qed.
+
+  Lemma Partition_sym : forall m m1 m2,
+   Partition m m1 m2 -> Partition m m2 m1.
+  Proof.
+  intros m m1 m2 (H,H'); split.
+  apply Disjoint_sym; auto.
+  intros; rewrite H'; intuition.
+  Qed.
+
+  Lemma Partition_Empty : forall m m1 m2, Partition m m1 m2 ->
+   (Empty m <-> (Empty m1 /\ Empty m2)).
+  Proof.
+  intros m m1 m2 (Hdisj,Heq). split.
+  intro He.
+  split; intros k e Hke; elim (He k e); rewrite Heq; auto.
+  intros (He1,He2) k e Hke. rewrite Heq in Hke. destruct Hke.
+  elim (He1 k e); auto.
+  elim (He2 k e); auto.
+  Qed.
+
+  Lemma Partition_Add :
+    forall m m' x e , ~In x m -> Add x e m m' ->
+    forall m1 m2, Partition m' m1 m2 ->
+     exists m3, (Add x e m3 m1 /\ Partition m m3 m2 \/
+                 Add x e m3 m2 /\ Partition m m1 m3).
+  Proof.
+  unfold Partition. intros m m' x e Hn Hadd m1 m2 (Hdisj,Hor).
+  assert (Heq : Equal m (remove x m')).
+   change (Equal m' (add x e m)) in Hadd. rewrite Hadd.
+   intro k. rewrite remove_o, add_o.
+   destruct eq_dec as [He|Hne]; auto.
+   rewrite <- He, <- not_find_in_iff; auto.
+  assert (H : MapsTo x e m').
+   change (Equal m' (add x e m)) in Hadd; rewrite Hadd.
+   apply add_1; auto.
+  rewrite Hor in H; destruct H.
+
+  (* first case : x in m1 *)
+  exists (remove x m1); left. split; [|split].
+  (* add *)
+  change (Equal m1 (add x e (remove x m1))).
+  intro k.
+  rewrite add_o, remove_o.
+  destruct eq_dec as [He|Hne]; auto.
+  rewrite <- He; apply find_1; auto.
+  (* disjoint *)
+  intros k (H1,H2). elim (Hdisj k). split; auto.
+  rewrite remove_in_iff in H1; destruct H1; auto.
+  (* mapsto *)
+  intros k' e'.
+  rewrite Heq, 2 remove_mapsto_iff, Hor.
+  intuition.
+  elim (Hdisj x); split; [exists e|exists e']; auto.
+  apply MapsTo_1 with k'; auto.
+
+  (* second case : x in m2 *)
+  exists (remove x m2); right. split; [|split].
+  (* add *)
+  change (Equal m2 (add x e (remove x m2))).
+  intro k.
+  rewrite add_o, remove_o.
+  destruct eq_dec as [He|Hne]; auto.
+  rewrite <- He; apply find_1; auto.
+  (* disjoint *)
+  intros k (H1,H2). elim (Hdisj k). split; auto.
+  rewrite remove_in_iff in H2; destruct H2; auto.
+  (* mapsto *)
+  intros k' e'.
+  rewrite Heq, 2 remove_mapsto_iff, Hor.
+  intuition.
+  elim (Hdisj x); split; [exists e'|exists e]; auto.
+  apply MapsTo_1 with k'; auto.
+  Qed.
+
+  Lemma Partition_fold :
+   forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A),
+   Proper (E.eq==>eq==>eqA==>eqA) f ->
+   transpose_neqkey eqA f ->
+   forall m m1 m2 i,
+   Partition m m1 m2 ->
+   eqA (fold f m i) (fold f m1 (fold f m2 i)).
+  Proof.
+  intros A eqA st f Comp Tra.
+  induction m as [m Hm|m m' IH k e Hn Hadd] using map_induction.
+
+  intros m1 m2 i Hp. rewrite (fold_Empty (eqA:=eqA)); auto.
+  rewrite (Partition_Empty Hp) in Hm. destruct Hm.
+  rewrite 2 (fold_Empty (eqA:=eqA)); auto. reflexivity.
+
+  intros m1 m2 i Hp.
+  destruct (Partition_Add Hn Hadd Hp) as (m3,[(Hadd',Hp')|(Hadd',Hp')]).
+  (* fst case: m3 is (k,e)::m1 *)
+  assert (~In k m3).
+   contradict Hn. destruct Hn as (e',He').
+   destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto.
+  transitivity (f k e (fold f m i)).
+  apply fold_Add with (eqA:=eqA); auto.
+  symmetry.
+  transitivity (f k e (fold f m3 (fold f m2 i))).
+  apply fold_Add with (eqA:=eqA); auto.
+  apply Comp; auto.
+  symmetry; apply IH; auto.
+  (* snd case: m3 is (k,e)::m2 *)
+  assert (~In k m3).
+   contradict Hn. destruct Hn as (e',He').
+   destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto.
+  assert (~In k m1).
+   contradict Hn. destruct Hn as (e',He').
+   destruct Hp' as (Hp1,Hp2). exists e'. rewrite Hp2; auto.
+  transitivity (f k e (fold f m i)).
+  apply fold_Add with (eqA:=eqA); auto.
+  transitivity (f k e (fold f m1 (fold f m3 i))).
+  apply Comp; auto using IH.
+  transitivity (fold f m1 (f k e (fold f m3 i))).
+  symmetry.
+  apply fold_commutes with (eqA:=eqA); auto.
+  apply fold_init with (eqA:=eqA); auto.
+  symmetry.
+  apply fold_Add with (eqA:=eqA); auto.
+  Qed.
+
+  Lemma Partition_cardinal : forall m m1 m2, Partition m m1 m2 ->
+   cardinal m = cardinal m1 + cardinal m2.
+  Proof.
+  intros.
+  rewrite (cardinal_fold m), (cardinal_fold m1).
+  set (f:=fun (_:key)(_:elt)=>S).
+  setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)).
+  rewrite <- cardinal_fold.
+  apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto.
+  apply Partition_fold with (eqA:=eq); repeat red; auto.
+  Qed.
+
+  Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 ->
+    let f := fun k (_:elt) => mem k m1 in
+   Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)).
+  Proof.
+  intros m m1 m2 Hm f.
+  assert (Hf : Proper (E.eq==>eq==>eq) f).
+   intros k k' Hk e e' _; unfold f; rewrite Hk; auto.
+  set (m1':= fst (partition f m)).
+  set (m2':= snd (partition f m)).
+  split; rewrite Equal_mapsto_iff; intros k e.
+  rewrite (@partition_iff_1 f Hf m m1') by auto.
+  unfold f.
+  rewrite <- mem_in_iff.
+  destruct Hm as (Hm,Hm').
+  rewrite Hm'.
+  intuition.
+  exists e; auto.
+  elim (Hm k); split; auto; exists e; auto.
+  rewrite (@partition_iff_2 f Hf m m2') by auto.
+  unfold f.
+  rewrite <- not_mem_in_iff.
+  destruct Hm as (Hm,Hm').
+  rewrite Hm'.
+  intuition.
+  elim (Hm k); split; auto; exists e; auto.
+  elim H1; exists e; auto.
+  Qed.
+
+  Lemma update_mapsto_iff : forall m m' k e,
+   MapsTo k e (update m m') <->
+    (MapsTo k e m' \/ (MapsTo k e m /\ ~In k m')).
+  Proof.
+  unfold update.
+  intros m m'.
+  pattern m', (fold (@add _) m' m). apply fold_rec.
+
+  intros m0 Hm0 k e.
+  assert (~In k m0) by (intros (e0,He0); apply (Hm0 k e0); auto).
+  intuition.
+  elim (Hm0 k e); auto.
+
+  intros k e m0 m1 m2 _ Hn Hadd IH k' e'.
+  change (Equal m2 (add k e m1)) in Hadd.
+  rewrite Hadd, 2 add_mapsto_iff, IH, add_in_iff. clear IH. intuition.
+  Qed.
+
+  Lemma update_dec : forall m m' k e, MapsTo k e (update m m') ->
+   { MapsTo k e m' } + { MapsTo k e m /\ ~In k m'}.
+  Proof.
+  intros m m' k e H. rewrite update_mapsto_iff in H.
+  destruct (In_dec m' k) as [H'|H']; [left|right]; intuition.
+  elim H'; exists e; auto.
+  Defined.
+
+  Lemma update_in_iff : forall m m' k,
+   In k (update m m') <-> In k m \/ In k m'.
+  Proof.
+  intros m m' k. split.
+  intros (e,H); rewrite update_mapsto_iff in H.
+  destruct H; [right|left]; exists e; intuition.
+  destruct (In_dec m' k) as [H|H].
+  destruct H as (e,H). intros _; exists e.
+  rewrite update_mapsto_iff; left; auto.
+  destruct 1 as [H'|H']; [|elim H; auto].
+  destruct H' as (e,H'). exists e.
+  rewrite update_mapsto_iff; right; auto.
+  Qed.
+
+  Lemma diff_mapsto_iff : forall m m' k e,
+   MapsTo k e (diff m m') <-> MapsTo k e m /\ ~In k m'.
+  Proof.
+  intros m m' k e.
+  unfold diff.
+  rewrite filter_iff.
+  intuition.
+  rewrite mem_1 in *; auto; discriminate.
+  intros ? ? Hk _ _ _; rewrite Hk; auto.
+  Qed.
+
+  Lemma diff_in_iff : forall m m' k,
+   In k (diff m m') <-> In k m /\ ~In k m'.
+  Proof.
+  intros m m' k. split.
+  intros (e,H); rewrite diff_mapsto_iff in H.
+  destruct H; split; auto. exists e; auto.
+  intros ((e,H),H'); exists e; rewrite diff_mapsto_iff; auto.
+  Qed.
+
+  Lemma restrict_mapsto_iff : forall m m' k e,
+   MapsTo k e (restrict m m') <-> MapsTo k e m /\ In k m'.
+  Proof.
+  intros m m' k e.
+  unfold restrict.
+  rewrite filter_iff.
+  intuition.
+  intros ? ? Hk _ _ _; rewrite Hk; auto.
+  Qed.
+
+  Lemma restrict_in_iff : forall m m' k,
+   In k (restrict m m') <-> In k m /\ In k m'.
+  Proof.
+  intros m m' k. split.
+  intros (e,H); rewrite restrict_mapsto_iff in H.
+  destruct H; split; auto. exists e; auto.
+  intros ((e,H),H'); exists e; rewrite restrict_mapsto_iff; auto.
+  Qed.
+
+  (** specialized versions analyzing only keys (resp. elements) *)
+
+  Definition filter_dom (f : key -> bool) := filter (fun k _ => f k).
+  Definition filter_range (f : elt -> bool) := filter (fun _ => f).
+  Definition for_all_dom (f : key -> bool) := for_all (fun k _ => f k).
+  Definition for_all_range (f : elt -> bool) := for_all (fun _ => f).
+  Definition exists_dom (f : key -> bool) := exists_ (fun k _ => f k).
+  Definition exists_range (f : elt -> bool) := exists_ (fun _ => f).
+  Definition partition_dom (f : key -> bool) := partition (fun k _ => f k).
+  Definition partition_range (f : elt -> bool) := partition (fun _ => f).
+
+ End Elt.
+
+ Add Parametric Morphism elt : (@cardinal elt)
+   with signature Equal ==> eq as cardinal_m.
+ Proof. intros; apply Equal_cardinal; auto. Qed.
+
+ Add Parametric Morphism elt : (@Disjoint elt)
+   with signature Equal ==> Equal ==> iff as Disjoint_m.
+ Proof.
+  intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros.
+  rewrite <- Hm1, <- Hm2; auto.
+  rewrite Hm1, Hm2; auto.
+ Qed.
+
+ Add Parametric Morphism elt : (@Partition elt)
+   with signature Equal ==> Equal ==> Equal ==> iff as Partition_m.
+ Proof.
+  intros m1 m1' Hm1 m2 m2' Hm2 m3 m3' Hm3. unfold Partition.
+  rewrite <- Hm2, <- Hm3.
+  split; intros (H,H'); split; auto; intros.
+  rewrite <- Hm1, <- Hm2, <- Hm3; auto.
+  rewrite Hm1, Hm2, Hm3; auto.
+ Qed.
+
+ Add Parametric Morphism elt : (@update elt)
+   with signature Equal ==> Equal ==> Equal as update_m.
+ Proof.
+  intros m1 m1' Hm1 m2 m2' Hm2.
+  setoid_replace (update m1 m2) with (update m1' m2); unfold update.
+  apply fold_Equal with (eqA:=Equal); auto.
+  intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto.
+  intros k k' e e' i Hneq x.
+  rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto.
+  apply fold_init with (eqA:=Equal); auto.
+  intros k k' Hk e e' He m m' Hm; rewrite Hk,He,Hm; red; auto.
+ Qed.
+
+ Add Parametric Morphism elt : (@restrict elt)
+   with signature Equal ==> Equal ==> Equal as restrict_m.
+ Proof.
+  intros m1 m1' Hm1 m2 m2' Hm2.
+  setoid_replace (restrict m1 m2) with (restrict m1' m2);
+   unfold restrict, filter.
+  apply fold_rel with (R:=Equal); try red; auto.
+   intros k e i i' H Hii' x.
+   pattern (mem k m2); rewrite Hm2. (* UGLY, see with Matthieu *)
+   destruct mem; rewrite Hii'; auto.
+  apply fold_Equal with (eqA:=Equal); auto.
+   intros k k' Hk e e' He m m' Hm; simpl in *.
+   pattern (mem k m2); rewrite Hk. (* idem *)
+   destruct mem; rewrite ?Hk,?He,Hm; red; auto.
+   intros k k' e e' i Hneq x.
+   case_eq (mem k m2); case_eq (mem k' m2); intros; auto.
+   rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto.
+ Qed.
+
+ Add Parametric Morphism elt : (@diff elt)
+   with signature Equal ==> Equal ==> Equal as diff_m.
+ Proof.
+  intros m1 m1' Hm1 m2 m2' Hm2.
+  setoid_replace (diff m1 m2) with (diff m1' m2);
+   unfold diff, filter.
+  apply fold_rel with (R:=Equal); try red; auto.
+   intros k e i i' H Hii' x.
+   pattern (mem k m2); rewrite Hm2. (* idem *)
+   destruct mem; simpl; rewrite Hii'; auto.
+  apply fold_Equal with (eqA:=Equal); auto.
+   intros k k' Hk e e' He m m' Hm; simpl in *.
+   pattern (mem k m2); rewrite Hk. (* idem *)
+   destruct mem; simpl; rewrite ?Hk,?He,Hm; red; auto.
+   intros k k' e e' i Hneq x.
+   case_eq (mem k m2); case_eq (mem k' m2); intros; simpl; auto.
+   rewrite !add_o; do 2 destruct eq_dec; auto. elim Hneq; eauto.
+ Qed.
+
+End WProperties_fun.
+
+(** * Same Properties for self-contained weak maps and for full maps *)
+
+Module WProperties (M:WS) := WProperties_fun M.E M.
+Module Properties := WProperties.
+
+(** * Properties specific to maps with ordered keys *)
+
+Module OrdProperties (M:S).
+ Module Import ME := OrderedTypeFacts M.E.
+ Module Import O:=KeyOrderedType M.E.
+ Module Import P:=Properties M.
+ Import F.
+ Import M.
+
+ Section Elt.
+  Variable elt:Type.
+
+  Notation eqke := (@eqke elt).
+  Notation eqk := (@eqk elt).
+  Notation ltk := (@ltk elt).
+  Notation cardinal := (@cardinal elt).
+  Notation Equal := (@Equal elt).
+  Notation Add := (@Add elt).
+
+  Definition Above x (m:t elt) := forall y, In y m -> E.lt y x.
+  Definition Below x (m:t elt) := forall y, In y m -> E.lt x y.
+
+  Section Elements.
+
+  Lemma sort_equivlistA_eqlistA : forall l l' : list (key*elt),
+   sort ltk l -> sort ltk l' -> equivlistA eqke l l' -> eqlistA eqke l l'.
+  Proof.
+  apply SortA_equivlistA_eqlistA; eauto with *.
+  Qed.
+
+  Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto.
+
+  Definition gtb (p p':key*elt) :=
+    match E.compare (fst p) (fst p') with GT _ => true | _ => false end.
+  Definition leb p := fun p' => negb (gtb p p').
+
+  Definition elements_lt p m := List.filter (gtb p) (elements m).
+  Definition elements_ge p m := List.filter (leb p) (elements m).
+
+  Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p.
+  Proof.
+   intros (x,e) (y,e'); unfold gtb, O.ltk; simpl.
+   destruct (E.compare x y); intuition; try discriminate; ME.order.
+  Qed.
+
+  Lemma leb_1 : forall p p', leb p p' = true <-> ~ltk p' p.
+  Proof.
+   intros (x,e) (y,e'); unfold leb, gtb, O.ltk; simpl.
+   destruct (E.compare x y); intuition; try discriminate; ME.order.
+  Qed.
+
+  Lemma gtb_compat : forall p, Proper (eqke==>eq) (gtb p).
+  Proof.
+   red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H.
+   generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e''));
+    destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto.
+   unfold O.ltk in *; simpl in *; intros.
+   symmetry; rewrite H2.
+   apply ME.eq_lt with a; auto.
+   rewrite <- H1; auto.
+   unfold O.ltk in *; simpl in *; intros.
+   rewrite H1.
+   apply ME.eq_lt with b; auto.
+   rewrite <- H2; auto.
+  Qed.
+
+  Lemma leb_compat : forall p, Proper (eqke==>eq) (leb p).
+  Proof.
+   red; intros x a b H.
+   unfold leb; f_equal; apply gtb_compat; auto.
+  Qed.
+
+  Hint Resolve gtb_compat leb_compat elements_3 : map.
+
+  Lemma elements_split : forall p m,
+    elements m = elements_lt p m ++ elements_ge p m.
+  Proof.
+  unfold elements_lt, elements_ge, leb; intros.
+  apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with *.
+  intros; destruct x; destruct y; destruct p.
+  rewrite gtb_1 in H; unfold O.ltk in H; simpl in *.
+  assert (~ltk (t1,e0) (k,e1)).
+   unfold gtb, O.ltk in *; simpl in *.
+   destruct (E.compare k t1); intuition; try discriminate; ME.order.
+  unfold O.ltk in *; simpl in *; ME.order.
+  Qed.
+
+  Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' ->
+    eqlistA eqke (elements m')
+                 (elements_lt (x,e) m ++ (x,e):: elements_ge (x,e) m).
+  Proof.
+  intros; unfold elements_lt, elements_ge.
+  apply sort_equivlistA_eqlistA; auto with *.
+  apply (@SortA_app _ eqke); auto with *.
+  apply (@filter_sort _ eqke); auto with *; clean_eauto.
+  constructor; auto with map.
+  apply (@filter_sort _ eqke); auto with *; clean_eauto.
+  rewrite (@InfA_alt _ eqke); auto with *; try (clean_eauto; fail).
+  intros.
+  rewrite filter_InA in H1; auto with *; destruct H1.
+  rewrite leb_1 in H2.
+  destruct y; unfold O.ltk in *; simpl in *.
+  rewrite <- elements_mapsto_iff in H1.
+  assert (~E.eq x t0).
+   contradict H.
+   exists e0; apply MapsTo_1 with t0; auto.
+  ME.order.
+  apply (@filter_sort _ eqke); auto with *; clean_eauto.
+  intros.
+  rewrite filter_InA in H1; auto with *; destruct H1.
+  rewrite gtb_1 in H3.
+  destruct y; destruct x0; unfold O.ltk in *; simpl in *.
+  inversion_clear H2.
+  red in H4; simpl in *; destruct H4.
+  ME.order.
+  rewrite filter_InA in H4; auto with *; destruct H4.
+  rewrite leb_1 in H4.
+  unfold O.ltk in *; simpl in *; ME.order.
+  red; intros a; destruct a.
+  rewrite InA_app_iff, InA_cons, 2 filter_InA,
+    <-2 elements_mapsto_iff, leb_1, gtb_1,
+    find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
+    add_mapsto_iff by (auto with *).
+  unfold O.eqke, O.ltk; simpl.
+  destruct (E.compare t0 x); intuition; try fold (~E.eq x t0); auto.
+  - elim H; exists e0; apply MapsTo_1 with t0; auto.
+  - fold (~E.lt t0 x); auto.
+  Qed.
+
+  Lemma elements_Add_Above : forall m m' x e,
+   Above x m -> Add x e m m' ->
+     eqlistA eqke (elements m') (elements m ++ (x,e)::nil).
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with *.
+  apply (@SortA_app _ eqke); auto with *.
+  intros.
+  inversion_clear H2.
+  destruct x0; destruct y.
+  rewrite <- elements_mapsto_iff in H1.
+  unfold O.eqke, O.ltk in *; simpl in *; destruct H3.
+  apply ME.lt_eq with x; auto.
+  apply H; firstorder.
+  inversion H3.
+  red; intros a; destruct a.
+  rewrite InA_app_iff, InA_cons, InA_nil, <- 2 elements_mapsto_iff,
+   find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
+   add_mapsto_iff by (auto with *).
+  unfold O.eqke; simpl. intuition.
+  destruct (E.eq_dec x t0) as [Heq|Hneq]; auto.
+  exfalso.
+  assert (In t0 m).
+   exists e0; auto.
+  generalize (H t0 H1).
+  ME.order.
+  Qed.
+
+  Lemma elements_Add_Below : forall m m' x e,
+   Below x m -> Add x e m m' ->
+     eqlistA eqke (elements m') ((x,e)::elements m).
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with *.
+  change (sort ltk (((x,e)::nil) ++ elements m)).
+  apply (@SortA_app _ eqke); auto with *.
+  intros.
+  inversion_clear H1.
+  destruct y; destruct x0.
+  rewrite <- elements_mapsto_iff in H2.
+  unfold O.eqke, O.ltk in *; simpl in *; destruct H3.
+  apply ME.eq_lt with x; auto.
+  apply H; firstorder.
+  inversion H3.
+  red; intros a; destruct a.
+  rewrite InA_cons, <- 2 elements_mapsto_iff,
+    find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
+    add_mapsto_iff by (auto with *).
+  unfold O.eqke; simpl. intuition.
+  destruct (E.eq_dec x t0) as [Heq|Hneq]; auto.
+  exfalso.
+  assert (In t0 m).
+   exists e0; auto.
+  generalize (H t0 H1).
+  ME.order.
+  Qed.
+
+  Lemma elements_Equal_eqlistA : forall (m m': t elt),
+   Equal m m' -> eqlistA eqke (elements m) (elements m').
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with *.
+  red; intros.
+  destruct x; do 2 rewrite <- elements_mapsto_iff.
+  do 2 rewrite find_mapsto_iff; rewrite H; split; auto.
+  Qed.
+
+  End Elements.
+
+  Section Min_Max_Elt.
+
+  (** We emulate two [max_elt] and [min_elt] functions. *)
+
+  Fixpoint max_elt_aux (l:list (key*elt)) := match l with
+    | nil => None
+    | (x,e)::nil => Some (x,e)
+    | (x,e)::l => max_elt_aux l
+    end.
+  Definition max_elt m := max_elt_aux (elements m).
+
+  Lemma max_elt_Above :
+   forall m x e, max_elt m = Some (x,e) -> Above x (remove x m).
+  Proof.
+  red; intros.
+  rewrite remove_in_iff in H0.
+  destruct H0.
+  rewrite elements_in_iff in H1.
+  destruct H1.
+  unfold max_elt in *.
+  generalize (elements_3 m).
+  revert x e H y x0 H0 H1.
+  induction (elements m).
+  simpl; intros; try discriminate.
+  intros.
+  destruct a; destruct l; simpl in *.
+  injection H as -> ->.
+  inversion_clear H1.
+  red in H; simpl in *; intuition.
+  elim H0; eauto.
+  inversion H.
+  change (max_elt_aux (p::l) = Some (x,e)) in H.
+  generalize (IHl x e H); clear IHl; intros IHl.
+  inversion_clear H1; [ | inversion_clear H2; eauto ].
+  red in H3; simpl in H3; destruct H3.
+  destruct p as (p1,p2).
+  destruct (E.eq_dec p1 x) as [Heq|Hneq].
+  apply ME.lt_eq with p1; auto.
+   inversion_clear H2.
+   inversion_clear H5.
+   red in H2; simpl in H2; ME.order.
+  apply E.lt_trans with p1; auto.
+   inversion_clear H2.
+   inversion_clear H5.
+   red in H2; simpl in H2; ME.order.
+  eapply IHl; eauto.
+  econstructor; eauto.
+  red; eauto.
+  inversion H2; auto.
+  Qed.
+
+  Lemma max_elt_MapsTo :
+   forall m x e, max_elt m = Some (x,e) -> MapsTo x e m.
+  Proof.
+  intros.
+  unfold max_elt in *.
+  rewrite elements_mapsto_iff.
+  induction (elements m).
+  simpl; try discriminate.
+  destruct a; destruct l; simpl in *.
+  injection H; intros; subst; constructor; red; auto.
+  constructor 2; auto.
+  Qed.
+
+  Lemma max_elt_Empty :
+   forall m, max_elt m = None -> Empty m.
+  Proof.
+  intros.
+  unfold max_elt in *.
+  rewrite elements_Empty.
+  induction (elements m); auto.
+  destruct a; destruct l; simpl in *; try discriminate.
+  assert (H':=IHl H); discriminate.
+  Qed.
+
+  Definition min_elt m : option (key*elt) := match elements m with
+   | nil => None
+   | (x,e)::_ => Some (x,e)
+  end.
+
+  Lemma min_elt_Below :
+   forall m x e, min_elt m = Some (x,e) -> Below x (remove x m).
+  Proof.
+  unfold min_elt, Below; intros.
+  rewrite remove_in_iff in H0; destruct H0.
+  rewrite elements_in_iff in H1.
+  destruct H1.
+  generalize (elements_3 m).
+  destruct (elements m).
+  try discriminate.
+  destruct p; injection H as -> ->; intros H4.
+  inversion_clear H1 as [? ? H2|? ? H2].
+  red in H2; destruct H2; simpl in *; ME.order.
+  inversion_clear H4. rename H1 into H3.
+  rewrite (@InfA_alt _ eqke) in H3; eauto with *.
+  apply (H3 (y,x0)); auto.
+  Qed.
+
+  Lemma min_elt_MapsTo :
+   forall m x e, min_elt m = Some (x,e) -> MapsTo x e m.
+  Proof.
+  intros.
+  unfold min_elt in *.
+  rewrite elements_mapsto_iff.
+  destruct (elements m).
+  simpl; try discriminate.
+  destruct p; simpl in *.
+  injection H; intros; subst; constructor; red; auto.
+  Qed.
+
+  Lemma min_elt_Empty :
+   forall m, min_elt m = None -> Empty m.
+  Proof.
+  intros.
+  unfold min_elt in *.
+  rewrite elements_Empty.
+  destruct (elements m); auto.
+  destruct p; simpl in *; discriminate.
+  Qed.
+
+  End Min_Max_Elt.
+
+  Section Induction_Principles.
+
+  Lemma map_induction_max :
+   forall P : t elt -> Type,
+   (forall m, Empty m -> P m) ->
+   (forall m m', P m -> forall x e, Above x m -> Add x e m m' -> P m') ->
+   forall m, P m.
+  Proof.
+  intros; remember (cardinal m) as n; revert m Heqn; induction n; intros.
+  apply X; apply cardinal_inv_1; auto.
+
+  case_eq (max_elt m); intros.
+  destruct p.
+  assert (Add k e (remove k m) m).
+   red; intros.
+   rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto.
+   apply find_1; apply MapsTo_1 with k; auto.
+   apply max_elt_MapsTo; auto.
+  apply X0 with (remove k m) k e; auto with map.
+  apply IHn.
+  assert (S n = S (cardinal (remove k m))).
+   rewrite Heqn.
+   eapply cardinal_2; eauto with map.
+  inversion H1; auto.
+  eapply max_elt_Above; eauto.
+
+  apply X; apply max_elt_Empty; auto.
+  Qed.
+
+  Lemma map_induction_min :
+   forall P : t elt -> Type,
+   (forall m, Empty m -> P m) ->
+   (forall m m', P m -> forall x e, Below x m -> Add x e m m' -> P m') ->
+   forall m, P m.
+  Proof.
+  intros; remember (cardinal m) as n; revert m Heqn; induction n; intros.
+  apply X; apply cardinal_inv_1; auto.
+
+  case_eq (min_elt m); intros.
+  destruct p.
+  assert (Add k e (remove k m) m).
+   red; intros.
+   rewrite add_o; rewrite remove_o; destruct (eq_dec k y); eauto.
+   apply find_1; apply MapsTo_1 with k; auto.
+   apply min_elt_MapsTo; auto.
+  apply X0 with (remove k m) k e; auto.
+  apply IHn.
+  assert (S n = S (cardinal (remove k m))).
+   rewrite Heqn.
+   eapply cardinal_2; eauto with map.
+  inversion H1; auto.
+  eapply min_elt_Below; eauto.
+
+  apply X; apply min_elt_Empty; auto.
+  Qed.
+
+  End Induction_Principles.
+
+  Section Fold_properties.
+
+  (** The following lemma has already been proved on Weak Maps,
+      but with one additional hypothesis (some [transpose] fact). *)
+
+  Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence  eqA)
+   (f:key->elt->A->A)(i:A),
+   Proper (E.eq==>eq==>eqA==>eqA) f ->
+   Equal m1 m2 ->
+   eqA (fold f m1 i) (fold f m2 i).
+  Proof.
+  intros m1 m2 A eqA st f i Hf Heq.
+  rewrite 2 fold_spec_right.
+  apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
+  intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto.
+  apply eqlistA_rev. apply elements_Equal_eqlistA. auto.
+  Qed.
+
+  Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)
+   (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f),
+   Above x m1 -> Add x e m1 m2 ->
+   eqA (fold f m2 i) (f x e (fold f m1 i)).
+  Proof.
+  intros. rewrite 2 fold_spec_right. set (f':=uncurry f).
+  transitivity (fold_right f' i (rev (elements m1 ++ (x,e)::nil))).
+  apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
+  intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto.
+  apply eqlistA_rev.
+  apply elements_Add_Above; auto.
+  rewrite distr_rev; simpl.
+  reflexivity.
+  Qed.
+
+  Lemma fold_Add_Below : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)
+   (f:key->elt->A->A)(i:A) (P:Proper (E.eq==>eq==>eqA==>eqA) f),
+   Below x m1 -> Add x e m1 m2 ->
+   eqA (fold f m2 i) (fold f m1 (f x e i)).
+  Proof.
+  intros. rewrite 2 fold_spec_right. set (f':=uncurry f).
+  transitivity (fold_right f' i (rev (((x,e)::nil)++elements m1))).
+  apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto.
+  intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto.
+  apply eqlistA_rev.
+  simpl; apply elements_Add_Below; auto.
+  rewrite distr_rev; simpl.
+  rewrite fold_right_app.
+  reflexivity.
+  Qed.
+
+  End Fold_properties.
+
+ End Elt.
+
+End OrdProperties.
diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v
new file mode 100644
index 0000000000..b23885154b
--- /dev/null
+++ b/theories/FSets/FMapFullAVL.v
@@ -0,0 +1,827 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(* Finite map library.  *)
+
+(** * FMapFullAVL
+
+   This file contains some complements to [FMapAVL].
+
+   - Functor [AvlProofs] proves that trees of [FMapAVL] are not only
+   binary search trees, but moreover well-balanced ones. This is done
+   by proving that all operations preserve the balancing.
+
+   - We then pack the previous elements in a [IntMake] functor
+   similar to the one of [FMapAVL], but richer.
+
+   - In final [IntMake_ord] functor, the [compare] function is
+   different from the one in [FMapAVL]: this non-structural
+   version is closer to the original Ocaml code.
+
+*)
+
+Require Import FunInd Recdef FMapInterface FMapList ZArith Int FMapAVL Lia.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module AvlProofs (Import I:Int)(X: OrderedType).
+Module Import Raw := Raw I X.
+Module Import II:=MoreInt(I).
+Import Raw.Proofs.
+Local Open Scope pair_scope.
+Local Open Scope Int_scope.
+
+Ltac omega_max := i2z_refl; lia.
+
+Section Elt.
+Variable elt : Type.
+Implicit Types m r : t elt.
+
+(** * AVL trees *)
+
+(** [avl s] : [s] is a properly balanced AVL tree,
+    i.e. for any node the heights of the two children
+    differ by at most 2 *)
+
+Inductive avl : t elt -> Prop :=
+  | RBLeaf : avl (Leaf _)
+  | RBNode : forall x e l r h,
+      avl l ->
+      avl r ->
+      -(2) <= height l - height r <= 2 ->
+      h = max (height l) (height r) + 1 ->
+      avl (Node l x e r h).
+
+
+(** * Automation and dedicated tactics about [avl]. *)
+
+Hint Constructors avl : core.
+
+Lemma height_non_negative : forall (s : t elt), avl s ->
+ height s >= 0.
+Proof.
+ induction s; simpl; intros; auto with zarith.
+ inv avl; intuition; omega_max.
+Qed.
+
+Ltac avl_nn_hyp H :=
+     let nz := fresh "nz" in assert (nz := height_non_negative H).
+
+Ltac avl_nn h :=
+  let t := type of h in
+  match type of t with
+   | Prop => avl_nn_hyp h
+   | _ => match goal with H : avl h |- _ => avl_nn_hyp H end
+  end.
+
+(* Repeat the previous tactic.
+   Drawback: need to clear the [avl _] hyps ... Thank you Ltac *)
+
+Ltac avl_nns :=
+  match goal with
+     | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns
+     | _ => idtac
+  end.
+
+
+(** * Basic results about [avl], [height] *)
+
+Lemma avl_node : forall x e l r, avl l -> avl r ->
+ -(2) <= height l - height r <= 2 ->
+ avl (Node l x e r (max (height l) (height r) + 1)).
+Proof.
+  intros; auto.
+Qed.
+Hint Resolve avl_node : core.
+
+(** Results about [height] *)
+
+Lemma height_0 : forall l, avl l -> height l = 0 ->
+ l = Leaf _.
+Proof.
+ destruct 1; intuition; simpl in *.
+ avl_nns; simpl in *; exfalso; omega_max.
+Qed.
+
+
+(** * Empty map *)
+
+Lemma empty_avl : avl (empty elt).
+Proof.
+ unfold empty; auto.
+Qed.
+
+
+(** * Helper functions *)
+
+Lemma create_avl :
+ forall l x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 ->
+ avl (create l x e r).
+Proof.
+ unfold create; auto.
+Qed.
+
+Lemma create_height :
+ forall l x e r, avl l -> avl r ->  -(2) <= height l - height r <= 2 ->
+ height (create l x e r) = max (height l) (height r) + 1.
+Proof.
+ unfold create; intros; auto.
+Qed.
+
+Lemma bal_avl : forall l x e r, avl l -> avl r ->
+ -(3) <= height l - height r <= 3 -> avl (bal l x e r).
+Proof.
+ intros l x e r; functional induction (bal l x e r); intros; clearf;
+ inv avl; simpl in *;
+ match goal with |- avl (assert_false _ _ _ _) => avl_nns
+  | _ => repeat apply create_avl; simpl in *; auto
+ end; omega_max.
+Qed.
+
+Lemma bal_height_1 : forall l x e r, avl l -> avl r ->
+ -(3) <= height l - height r <= 3 ->
+ 0 <= height (bal l x e r) - max (height l) (height r) <= 1.
+Proof.
+ intros l x e r; functional induction (bal l x e r); intros; clearf;
+ inv avl; avl_nns; simpl in *; omega_max.
+Qed.
+
+Lemma bal_height_2 :
+ forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 ->
+ height (bal l x e r) == max (height l) (height r) +1.
+Proof.
+ intros l x e r; functional induction (bal l x e r); intros; clearf;
+ inv avl; avl_nns; simpl in *; omega_max.
+Qed.
+
+Ltac omega_bal := match goal with
+  | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] =>
+     generalize (bal_height_1 x e H H') (bal_height_2 x e H H');
+     omega_max
+  end.
+
+(** * Insertion *)
+
+Lemma add_avl_1 :  forall m x e, avl m ->
+ avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1.
+Proof.
+ intros m x e; functional induction (add x e m); intros; inv avl; simpl in *.
+ intuition; try constructor; simpl; auto; try omega_max.
+ (* LT *)
+ destruct IHt; auto.
+ split.
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+ (* EQ *)
+ intuition; omega_max.
+ (* GT *)
+ destruct IHt; auto.
+ split.
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+Qed.
+
+Lemma add_avl : forall m x e, avl m -> avl (add x e m).
+Proof.
+ intros; generalize (add_avl_1 x e H); intuition.
+Qed.
+Hint Resolve add_avl : core.
+
+(** * Extraction of minimum binding *)
+
+Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) ->
+ avl (remove_min l x e r)#1 /\
+ 0 <= height (Node l x e r h) - height (remove_min l x e r)#1 <= 1.
+Proof.
+ intros l x e r; functional induction (remove_min l x e r); simpl in *; intros.
+ inv avl; simpl in *; split; auto.
+ avl_nns; omega_max.
+ inversion_clear H.
+ rewrite e0 in IHp;simpl in IHp;destruct (IHp _x); auto.
+ split; simpl in *.
+ apply bal_avl; auto; omega_max.
+ omega_bal.
+Qed.
+
+Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) ->
+    avl (remove_min l x e r)#1.
+Proof.
+ intros; generalize (remove_min_avl_1 H); intuition.
+Qed.
+
+(** * Merging two trees *)
+
+Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 ->
+ -(2) <= height m1 - height m2 <= 2 ->
+ avl (merge m1 m2) /\
+ 0<= height (merge m1 m2) - max (height m1) (height m2) <=1.
+Proof.
+ intros m1 m2; functional induction (merge m1 m2); intros;
+ try factornode _x _x0 _x1 _x2 _x3 as m1.
+ simpl; split; auto; avl_nns; omega_max.
+ simpl; split; auto; avl_nns; omega_max.
+ generalize (remove_min_avl_1 H0).
+ rewrite e1; destruct 1.
+ split.
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+Qed.
+
+Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 ->
+  -(2) <= height m1 - height m2 <= 2 -> avl (merge m1 m2).
+Proof.
+ intros; generalize (merge_avl_1 H H0 H1); intuition.
+Qed.
+
+
+(** * Deletion *)
+
+Lemma remove_avl_1 : forall m x, avl m ->
+ avl (remove x m) /\ 0 <= height m - height (remove x m) <= 1.
+Proof.
+ intros m x; functional induction (remove x m); intros.
+ split; auto; omega_max.
+ (* LT *)
+ inv avl.
+ destruct (IHt H0).
+ split.
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+ (* EQ *)
+ inv avl.
+ generalize (merge_avl_1 H0 H1 H2).
+ intuition omega_max.
+ (* GT *)
+ inv avl.
+ destruct (IHt H1).
+ split.
+ apply bal_avl; auto.
+ omega_max.
+ omega_bal.
+Qed.
+
+Lemma remove_avl : forall m x, avl m -> avl (remove x m).
+Proof.
+ intros; generalize (remove_avl_1 x H); intuition.
+Qed.
+Hint Resolve remove_avl : core.
+
+
+(** * Join *)
+
+Lemma join_avl_1 : forall l x d r, avl l -> avl r ->
+ avl (join l x d r) /\
+ 0<= height (join l x d r) - max (height l) (height r) <= 1.
+Proof.
+ join_tac.
+
+ split; simpl; auto.
+ destruct (add_avl_1 x d H0).
+ avl_nns; omega_max.
+ set (l:=Node ll lx ld lr lh) in *.
+ split; auto.
+ destruct (add_avl_1 x d H).
+ simpl (height (Leaf elt)).
+ avl_nns; omega_max.
+
+ inversion_clear H.
+ assert (height (Node rl rx rd rr rh) = rh); auto.
+ set (r := Node rl rx rd rr rh) in *; clearbody r.
+ destruct (Hlr x d r H2 H0); clear Hrl Hlr.
+ set (j := join lr x d r) in *; clearbody j.
+ simpl.
+ assert (-(3) <= height ll - height j <= 3) by omega_max.
+ split.
+ apply bal_avl; auto.
+ omega_bal.
+
+ inversion_clear H0.
+ assert (height (Node ll lx ld lr lh) = lh); auto.
+ set (l := Node ll lx ld lr lh) in *; clearbody l.
+ destruct (Hrl H H1); clear Hrl Hlr.
+ set (j := join l x d rl) in *; clearbody j.
+ simpl.
+ assert (-(3) <= height j - height rr <= 3) by omega_max.
+ split.
+ apply bal_avl; auto.
+ omega_bal.
+
+ clear Hrl Hlr.
+ assert (height (Node ll lx ld lr lh) = lh); auto.
+ assert (height (Node rl rx rd rr rh) = rh); auto.
+ set (l := Node ll lx ld lr lh) in *; clearbody l.
+ set (r := Node rl rx rd rr rh) in *; clearbody r.
+ assert (-(2) <= height l - height r <= 2) by omega_max.
+ split.
+ apply create_avl; auto.
+ rewrite create_height; auto; omega_max.
+Qed.
+
+Lemma join_avl : forall l x d r, avl l -> avl r -> avl (join l x d r).
+Proof.
+ intros; destruct (join_avl_1 x d H H0); auto.
+Qed.
+Hint Resolve join_avl : core.
+
+(** concat *)
+
+Lemma concat_avl : forall m1 m2, avl m1 -> avl m2 -> avl (concat m1 m2).
+Proof.
+ intros m1 m2; functional induction (concat m1 m2); auto.
+ intros; apply join_avl; auto.
+ generalize (remove_min_avl H0); rewrite e1; simpl; auto.
+Qed.
+Hint Resolve concat_avl : core.
+
+(** split *)
+
+Lemma split_avl : forall m x, avl m ->
+  avl (split x m)#l /\ avl (split x m)#r.
+Proof.
+ intros m x; functional induction (split x m); simpl; auto.
+ rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
+ simpl; inversion_clear 1; auto.
+ rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition.
+Qed.
+
+End Elt.
+Hint Constructors avl : core.
+
+Section Map.
+Variable elt elt' : Type.
+Variable f : elt -> elt'.
+
+Lemma map_height : forall m, height (map f m) = height m.
+Proof.
+destruct m; simpl; auto.
+Qed.
+
+Lemma map_avl : forall m, avl m -> avl (map f m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto; do 2 rewrite map_height; auto.
+Qed.
+
+End Map.
+
+Section Mapi.
+Variable elt elt' : Type.
+Variable f : key -> elt -> elt'.
+
+Lemma mapi_height : forall m, height (mapi f m) = height m.
+Proof.
+destruct m; simpl; auto.
+Qed.
+
+Lemma mapi_avl : forall m, avl m -> avl (mapi f m).
+Proof.
+induction m; simpl; auto.
+inversion_clear 1; constructor; auto; do 2 rewrite mapi_height; auto.
+Qed.
+
+End Mapi.
+
+Section Map_option.
+Variable elt elt' : Type.
+Variable f : key -> elt -> option elt'.
+
+Lemma map_option_avl : forall m, avl m -> avl (map_option f m).
+Proof.
+induction m; simpl; auto; intros.
+inv avl; destruct (f k e); auto using join_avl, concat_avl.
+Qed.
+
+End Map_option.
+
+Section Map2_opt.
+Variable elt elt' elt'' : Type.
+Variable f : key -> elt -> option elt' -> option elt''.
+Variable mapl : t elt -> t elt''.
+Variable mapr : t elt' -> t elt''.
+Hypothesis mapl_avl : forall m, avl m -> avl (mapl m).
+Hypothesis mapr_avl : forall m', avl m' -> avl (mapr m').
+
+Notation map2_opt := (map2_opt f mapl mapr).
+
+Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 ->
+ avl (map2_opt m1 m2).
+Proof.
+intros m1 m2; functional induction (map2_opt m1 m2); auto;
+factornode _x0 _x1 _x2 _x3 _x4 as r2; intros;
+destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl;
+auto using join_avl, concat_avl.
+Qed.
+
+End Map2_opt.
+
+Section Map2.
+Variable elt elt' elt'' : Type.
+Variable f : option elt -> option elt' -> option elt''.
+
+Lemma map2_avl : forall m1 m2, avl m1 -> avl m2 -> avl (map2 f m1 m2).
+Proof.
+unfold map2; auto using map2_opt_avl, map_option_avl.
+Qed.
+
+End Map2.
+End AvlProofs.
+
+(** * Encapsulation
+
+   We can implement [S] with balanced binary search trees.
+   When compared to [FMapAVL], we maintain here two invariants
+   (bst and avl) instead of only bst, which is enough for fulfilling
+   the FMap interface.
+*)
+
+Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
+
+ Module E := X.
+ Module Import AvlProofs := AvlProofs I X.
+ Import Raw.
+ Import Raw.Proofs.
+
+ #[universes(template)]
+ Record bbst (elt:Type) :=
+  Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}.
+
+ Definition t := bbst.
+ Definition key := E.t.
+
+ Section Elt.
+ Variable elt elt' elt'': Type.
+
+ Implicit Types m : t elt.
+ Implicit Types x y : key.
+ Implicit Types e : elt.
+
+ Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt).
+ Definition is_empty m : bool := is_empty (this m).
+ Definition add x e m : t elt :=
+  Bbst (add_bst x e (is_bst m)) (add_avl x e (is_avl m)).
+ Definition remove x m : t elt :=
+  Bbst (remove_bst x (is_bst m)) (remove_avl x (is_avl m)).
+ Definition mem x m : bool := mem x (this m).
+ Definition find x m : option elt := find x (this m).
+ Definition map f m : t elt' :=
+  Bbst (map_bst f (is_bst m)) (map_avl f (is_avl m)).
+ Definition mapi (f:key->elt->elt') m : t elt' :=
+  Bbst (mapi_bst f (is_bst m)) (mapi_avl f (is_avl m)).
+ Definition map2 f m (m':t elt') : t elt'' :=
+  Bbst (map2_bst f (is_bst m) (is_bst m')) (map2_avl f (is_avl m) (is_avl m')).
+ Definition elements m : list (key*elt) := elements (this m).
+ Definition cardinal m := cardinal (this m).
+ Definition fold (A:Type) (f:key->elt->A->A) m i := fold (A:=A) f (this m) i.
+ Definition equal cmp m m' : bool := equal cmp (this m) (this m').
+
+ Definition MapsTo x e m : Prop := MapsTo x e (this m).
+ Definition In x m : Prop := In0 x (this m).
+ Definition Empty m : Prop := Empty (this m).
+
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop := @PX.eqke elt.
+ Definition lt_key : (key*elt) -> (key*elt) -> Prop := @PX.ltk elt.
+
+ Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
+ Proof. intros m; exact (@MapsTo_1 _ (this m)). Qed.
+
+ Lemma mem_1 : forall m x, In x m -> mem x m = true.
+ Proof.
+ unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto.
+ apply (is_bst m).
+ Qed.
+
+ Lemma mem_2 : forall m x, mem x m = true -> In x m.
+ Proof.
+ unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto.
+ Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact (@empty_1 elt). Qed.
+
+ Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
+ Proof. intros m; exact (@is_empty_1 _ (this m)). Qed.
+ Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+ Proof. intros m; exact (@is_empty_2 _ (this m)). Qed.
+
+ Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
+ Proof. intros m x y e; exact (@add_1 elt _ x y e). Qed.
+ Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+ Proof. intros m x y e e'; exact (@add_2 elt _ x y e e'). Qed.
+ Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+ Proof. intros m x y e e'; exact (@add_3 elt _ x y e e'). Qed.
+
+ Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
+ Proof.
+ unfold In, remove; intros m x y; rewrite In_alt; simpl; apply remove_1; auto.
+ apply (is_bst m).
+ Qed.
+ Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+ Proof. intros m x y e; exact (@remove_2 elt _ x y e (is_bst m)). Qed.
+ Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
+ Proof. intros m x y e; exact (@remove_3 elt _ x y e (is_bst m)). Qed.
+
+
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
+ Proof. intros m x e; exact (@find_1 elt _ x e (is_bst m)). Qed.
+ Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+ Proof. intros m; exact (@find_2 elt (this m)). Qed.
+
+ Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+ Proof. intros m; exact (@fold_1 elt (this m) (is_bst m)). Qed.
+
+ Lemma elements_1 : forall m x e,
+   MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+ Proof.
+ intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto.
+ Qed.
+
+ Lemma elements_2 : forall m x e,
+   InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+ Proof.
+ intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto.
+ Qed.
+
+ Lemma elements_3 : forall m, sort lt_key (elements m).
+ Proof. intros m; exact (@elements_sort elt (this m) (is_bst m)). Qed.
+
+ Lemma elements_3w : forall m, NoDupA eq_key (elements m).
+ Proof. intros m; exact (@elements_nodup elt (this m) (is_bst m)). Qed.
+
+ Lemma cardinal_1 : forall m, cardinal m = length (elements m).
+ Proof. intro m; exact (@elements_cardinal elt (this m)). Qed.
+
+ Definition Equal m m' := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+   (forall k, In k m <-> In k m') /\
+   (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+ Definition Equivb cmp := Equiv (Cmp cmp).
+
+ Lemma Equivb_Equivb : forall cmp m m',
+  Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'.
+ Proof.
+ intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition.
+ generalize (H0 k); do 2 rewrite In_alt; intuition.
+ generalize (H0 k); do 2 rewrite In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- In_alt; intuition.
+ generalize (H0 k); do 2 rewrite <- In_alt; intuition.
+ Qed.
+
+ Lemma equal_1 : forall m m' cmp,
+   Equivb cmp m m' -> equal cmp m m' = true.
+ Proof.
+ unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb;
+  intros; simpl in *; rewrite equal_Equivb; auto.
+ Qed.
+
+ Lemma equal_2 : forall m m' cmp,
+   equal cmp m m' = true -> Equivb cmp m m'.
+ Proof.
+ unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb;
+  intros; simpl in *; rewrite <-equal_Equivb; auto.
+ Qed.
+
+ End Elt.
+
+ Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+ Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f (this m) x e). Qed.
+
+ Lemma map_2 : forall (elt elt':Type)(m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m.
+ Proof.
+ intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl.
+ apply map_2; auto.
+ Qed.
+
+ Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m ->
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+ Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f (this m) x e). Qed.
+ Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+ Proof.
+ intros elt elt' m x f; unfold In in *; do 2 rewrite In_alt; simpl; apply mapi_2; auto.
+ Qed.
+
+ Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
+    (x:key)(f:option elt->option elt'->option elt''),
+    In x m \/ In x m' ->
+    find x (map2 f m m') = f (find x m) (find x m').
+ Proof.
+ unfold find, map2, In; intros elt elt' elt'' m m' x f.
+ do 2 rewrite In_alt; intros; simpl; apply map2_1; auto.
+ apply (is_bst m).
+ apply (is_bst m').
+ Qed.
+
+ Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
+     (x:key)(f:option elt->option elt'->option elt''),
+     In x (map2 f m m') -> In x m \/ In x m'.
+ Proof.
+ unfold In, map2; intros elt elt' elt'' m m' x f.
+ do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto.
+ apply (is_bst m).
+ apply (is_bst m').
+ Qed.
+
+End IntMake.
+
+
+Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
+    Sord with Module Data := D
+            with Module MapS.E := X.
+
+  Module Data := D.
+  Module Import MapS := IntMake(I)(X).
+  Import AvlProofs.
+  Import Raw.Proofs.
+  Module Import MD := OrderedTypeFacts(D).
+  Module LO := FMapList.Make_ord(X)(D).
+
+  Definition t := MapS.t D.t.
+
+  Definition cmp e e' :=
+   match D.compare e e' with EQ _ => true | _ => false end.
+
+  Definition elements (m:t) :=
+    LO.MapS.Build_slist (Raw.Proofs.elements_sort (is_bst m)).
+
+  (** * As comparison function, we propose here a non-structural
+    version faithful to the code of Ocaml's Map library, instead of
+    the structural version of FMapAVL *)
+
+  Fixpoint cardinal_e (e:Raw.enumeration D.t) :=
+    match e with
+     | Raw.End _ => 0%nat
+     | Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e)
+    end.
+
+  Lemma cons_cardinal_e : forall m e,
+   cardinal_e (Raw.cons m e) = (Raw.cardinal m + cardinal_e e)%nat.
+  Proof.
+   induction m; simpl; intros; auto.
+   rewrite IHm1; simpl; rewrite <- plus_n_Sm; auto with arith.
+  Qed.
+
+  Definition cardinal_e_2 ee :=
+   (cardinal_e (fst ee) + cardinal_e (snd ee))%nat.
+
+  Local Unset Keyed Unification.
+
+  Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t)
+   { measure cardinal_e_2 ee } : comparison :=
+  match ee with
+  | (Raw.End _, Raw.End _) => Eq
+  | (Raw.End _, Raw.More _ _ _ _) => Lt
+  | (Raw.More _ _ _ _, Raw.End _) => Gt
+  | (Raw.More x1 d1 r1 e1, Raw.More x2 d2 r2 e2) =>
+      match X.compare x1 x2 with
+      | EQ _ => match D.compare d1 d2 with
+                | EQ _ => compare_aux (Raw.cons r1 e1, Raw.cons r2 e2)
+                | LT _ => Lt
+                | GT _ => Gt
+                end
+      | LT _ => Lt
+      | GT _ => Gt
+      end
+  end.
+  Proof.
+  intros; unfold cardinal_e_2; simpl;
+  abstract (do 2 rewrite cons_cardinal_e; lia ).
+  Defined.
+
+  Definition Cmp c :=
+   match c with
+    | Eq => LO.eq_list
+    | Lt => LO.lt_list
+    | Gt => (fun l1 l2 => LO.lt_list l2 l1)
+   end.
+
+  Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2,
+   X.eq x1 x2 -> D.eq d1 d2 ->
+   Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2).
+  Proof.
+   destruct c; simpl; intros; MX.elim_comp; auto.
+  Qed.
+  Hint Resolve cons_Cmp : core.
+
+  Lemma compare_aux_Cmp : forall e,
+   Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)).
+  Proof.
+  intros e; functional induction (compare_aux e); simpl in *;
+   auto; intros; try clear e0; try clear e3; try MX.elim_comp; auto.
+  rewrite 2 cons_1 in IHc; auto.
+  Qed.
+
+  Lemma compare_Cmp : forall m1 m2,
+    Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _)))
+     (Raw.elements m1) (Raw.elements m2).
+  Proof.
+  intros.
+  assert (H1:=cons_1 m1 (Raw.End _)).
+  assert (H2:=cons_1 m2 (Raw.End _)).
+  simpl in *; rewrite app_nil_r in *; rewrite <-H1,<-H2.
+  apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _),
+                           Raw.cons m2 (Raw.End _))).
+  Qed.
+
+  Definition eq (m1 m2 : t) := LO.eq_list (Raw.elements m1) (Raw.elements m2).
+  Definition lt (m1 m2 : t) := LO.lt_list (Raw.elements m1) (Raw.elements m2).
+
+  Definition compare (s s':t) : Compare lt eq s s'.
+  Proof.
+   destruct s as (s,b,a), s' as (s',b',a').
+   generalize (compare_Cmp s s').
+   destruct compare_aux; intros; [apply EQ|apply LT|apply GT]; red; auto.
+  Defined.
+
+
+  (* Proofs about [eq] and [lt] *)
+
+  Definition selements (m1 : t) :=
+   LO.MapS.Build_slist (elements_sort (is_bst m1)).
+
+  Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2).
+  Definition slt (m1 m2 : t) := LO.lt (selements m1) (selements m2).
+
+  Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2.
+  Proof.
+   unfold eq, seq, selements, elements, LO.eq; intuition.
+  Qed.
+
+  Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2.
+  Proof.
+   unfold lt, slt, selements, elements, LO.lt; intuition.
+  Qed.
+
+  Lemma eq_1 : forall (m m' : t), MapS.Equivb cmp m m' -> eq m m'.
+  Proof.
+  intros m m'.
+  rewrite eq_seq; unfold seq.
+  rewrite Equivb_Equivb.
+  rewrite Equivb_elements.
+  auto using LO.eq_1.
+  Qed.
+
+  Lemma eq_2 : forall m m', eq m m' -> MapS.Equivb cmp m m'.
+  Proof.
+  intros m m'.
+  rewrite eq_seq; unfold seq.
+  rewrite Equivb_Equivb.
+  rewrite Equivb_elements.
+  intros.
+  generalize (LO.eq_2 H).
+  auto.
+  Qed.
+
+  Lemma eq_refl : forall m : t, eq m m.
+  Proof.
+  intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl.
+  Qed.
+
+  Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+  Proof.
+  intros m1 m2; rewrite 2 eq_seq; unfold seq; intros; apply LO.eq_sym; auto.
+  Qed.
+
+  Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
+  Proof.
+  intros m1 m2 M3; rewrite 3 eq_seq; unfold seq.
+   intros; eapply LO.eq_trans; eauto.
+  Qed.
+
+  Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
+  Proof.
+  intros m1 m2 m3; rewrite 3 lt_slt; unfold slt;
+   intros; eapply LO.lt_trans; eauto.
+  Qed.
+
+  Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
+  Proof.
+  intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq;
+   intros; apply LO.lt_not_eq; auto.
+  Qed.
+
+End IntMake_ord.
+
+(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)
+
+Module Make (X: OrderedType) <: S with Module E := X
+ :=IntMake(Z_as_Int)(X).
+
+Module Make_ord (X: OrderedType)(D: OrderedType)
+ <: Sord with Module Data := D
+            with Module MapS.E := X
+ :=IntMake_ord(Z_as_Int)(X)(D).
+
diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v
new file mode 100644
index 0000000000..8970529103
--- /dev/null
+++ b/theories/FSets/FMapInterface.v
@@ -0,0 +1,321 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * Finite map library *)
+
+(** This file proposes interfaces for finite maps *)
+
+Require Export Bool DecidableType OrderedType.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** When compared with Ocaml Map, this signature has been split in
+    several parts :
+
+   - The first parts [WSfun] and [WS] propose signatures for weak
+     maps, which are maps with no ordering on the key type nor the
+     data type.  [WSfun] and [WS] are almost identical, apart from the
+     fact that [WSfun] is expressed in a functorial way whereas [WS]
+     is self-contained. For obtaining an instance of such signatures,
+     a decidable equality on keys in enough (see for example
+     [FMapWeakList]). These signatures contain the usual operators
+     (add, find, ...). The only function that asks for more is
+     [equal], whose first argument should be a comparison on data.
+
+   - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the
+     case where the key type is ordered. The main novelty is that
+     [elements] is required to produce sorted lists.
+
+   - Finally, [Sord] extends [S] with a complete comparison function. For
+     that, the data type should have a decidable total ordering as well.
+
+   If unsure, what you're looking for is probably [S]: apart from [Sord],
+   all other signatures are subsets of [S].
+
+   Some additional differences with Ocaml:
+
+    - no [iter] function, useless since Coq is purely functional
+    - [option] types are used instead of [Not_found] exceptions
+    - more functions are provided: [elements] and [cardinal] and [map2]
+
+*)
+
+
+Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true.
+
+(** ** Weak signature for maps
+
+    No requirements for an ordering on keys nor elements, only decidability
+    of equality on keys. First, a functorial signature: *)
+
+Module Type WSfun (E : DecidableType).
+
+  Definition key := E.t.
+  Hint Transparent key : core.
+
+  Parameter t : Type -> Type.
+  (** the abstract type of maps *)
+
+  Section Types.
+
+    Variable elt:Type.
+
+    Parameter empty : t elt.
+    (** The empty map. *)
+
+    Parameter is_empty : t elt -> bool.
+    (** Test whether a map is empty or not. *)
+
+    Parameter add : key -> elt -> t elt -> t elt.
+    (** [add x y m] returns a map containing the same bindings as [m],
+	plus a binding of [x] to [y]. If [x] was already bound in [m],
+	its previous binding disappears. *)
+
+    Parameter find : key -> t elt -> option elt.
+    (** [find x m] returns the current binding of [x] in [m],
+	or [None] if no such binding exists. *)
+
+    Parameter remove : key -> t elt -> t elt.
+    (** [remove x m] returns a map containing the same bindings as [m],
+	except for [x] which is unbound in the returned map. *)
+
+    Parameter mem : key -> t elt -> bool.
+    (** [mem x m] returns [true] if [m] contains a binding for [x],
+	and [false] otherwise. *)
+
+    Variable elt' elt'' : Type.
+
+    Parameter map : (elt -> elt') -> t elt -> t elt'.
+    (** [map f m] returns a map with same domain as [m], where the associated
+	value a of all bindings of [m] has been replaced by the result of the
+	application of [f] to [a]. Since Coq is purely functional, the order
+        in which the bindings are passed to [f] is irrelevant. *)
+
+    Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'.
+    (** Same as [map], but the function receives as arguments both the
+	key and the associated value for each binding of the map. *)
+
+    Parameter map2 :
+     (option elt -> option elt' -> option elt'') -> t elt -> t elt' ->  t elt''.
+    (** [map2 f m m'] creates a new map whose bindings belong to the ones
+        of either [m] or [m']. The presence and value for a key [k] is
+        determined by [f e e'] where [e] and [e'] are the (optional) bindings
+        of [k] in [m] and [m']. *)
+
+    Parameter elements : t elt -> list (key*elt).
+    (** [elements m] returns an assoc list corresponding to the bindings
+        of [m], in any order. *)
+
+    Parameter cardinal : t elt -> nat.
+    (** [cardinal m] returns the number of bindings in [m]. *)
+
+    Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A.
+    (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
+	where [k1] ... [kN] are the keys of all bindings in [m]
+	(in any order), and [d1] ... [dN] are the associated data. *)
+
+    Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool.
+    (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal,
+      that is, contain equal keys and associate them with equal data.
+      [cmp] is the equality predicate used to compare the data associated
+      with the keys. *)
+
+    Section Spec.
+
+      Variable m m' m'' : t elt.
+      Variable x y z : key.
+      Variable e e' : elt.
+
+      Parameter MapsTo : key -> elt -> t elt -> Prop.
+
+      Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m.
+
+      Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.
+
+      Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p').
+
+      Definition eq_key_elt (p p':key*elt) :=
+          E.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+    (** Specification of [MapsTo] *)
+      Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
+
+    (** Specification of [mem] *)
+      Parameter mem_1 : In x m -> mem x m = true.
+      Parameter mem_2 : mem x m = true -> In x m.
+
+    (** Specification of [empty] *)
+      Parameter empty_1 : Empty empty.
+
+    (** Specification of [is_empty] *)
+      Parameter is_empty_1 : Empty m -> is_empty m = true.
+      Parameter is_empty_2 : is_empty m = true -> Empty m.
+
+    (** Specification of [add] *)
+      Parameter add_1 : E.eq x y -> MapsTo y e (add x e m).
+      Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+      Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+
+    (** Specification of [remove] *)
+      Parameter remove_1 : E.eq x y -> ~ In y (remove x m).
+      Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+      Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
+
+    (** Specification of [find] *)
+      Parameter find_1 : MapsTo x e m -> find x m = Some e.
+      Parameter find_2 : find x m = Some e -> MapsTo x e m.
+
+    (** Specification of [elements] *)
+      Parameter elements_1 :
+        MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+      Parameter elements_2 :
+        InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+      (** When compared with ordered maps, here comes the only
+         property that is really weaker: *)
+      Parameter elements_3w : NoDupA eq_key (elements m).
+
+    (** Specification of [cardinal] *)
+      Parameter cardinal_1 : cardinal m = length (elements m).
+
+    (** Specification of [fold] *)
+      Parameter fold_1 :
+	forall (A : Type) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+
+    (** Equality of maps *)
+
+    (** Caveat: there are at least three distinct equality predicates on maps.
+      - The simpliest (and maybe most natural) way is to consider keys up to
+        their equivalence [E.eq], but elements up to Leibniz equality, in
+        the spirit of [eq_key_elt] above. This leads to predicate [Equal].
+      - Unfortunately, this [Equal] predicate can't be used to describe
+        the [equal] function, since this function (for compatibility with
+        ocaml) expects a boolean comparison [cmp] that may identify more
+        elements than Leibniz. So logical specification of [equal] is done
+        via another predicate [Equivb]
+      - This predicate [Equivb] is quite ad-hoc with its boolean [cmp],
+        it can be generalized in a [Equiv] expecting a more general
+        (possibly non-decidable) equality predicate on elements *)
+
+     Definition Equal m m' := forall y, find y m = find y m'.
+     Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+         (forall k, In k m <-> In k m') /\
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+     Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp).
+
+     (** Specification of [equal] *)
+
+     Variable cmp : elt -> elt -> bool.
+
+     Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true.
+     Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'.
+
+    End Spec.
+   End Types.
+
+    (** Specification of [map] *)
+      Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+      Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
+        In x (map f m) -> In x m.
+
+    (** Specification of [mapi] *)
+      Parameter mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m ->
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+      Parameter mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+
+    (** Specification of [map2] *)
+      Parameter map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''),
+	In x m \/ In x m' ->
+        find x (map2 f m m') = f (find x m) (find x m').
+
+     Parameter map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''),
+        In x (map2 f m m') -> In x m \/ In x m'.
+
+  Hint Immediate MapsTo_1 mem_2 is_empty_2
+    map_2 mapi_2 add_3 remove_3 find_2
+    : map.
+  Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1
+    remove_2 find_1 fold_1 map_1 mapi_1 mapi_2
+    : map.
+
+End WSfun.
+
+
+(** ** Static signature for Weak Maps
+
+    Similar to [WSfun] but expressed in a self-contained way. *)
+
+Module Type WS.
+  Declare Module E : DecidableType.
+  Include WSfun E.
+End WS.
+
+
+
+(** ** Maps on ordered keys, functorial signature *)
+
+Module Type Sfun (E : OrderedType).
+  Include WSfun E.
+  Section elt.
+  Variable elt:Type.
+   Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p').
+   (* Additional specification of [elements] *)
+   Parameter elements_3 : forall m, sort lt_key (elements m).
+   (** Remark: since [fold] is specified via [elements], this stronger
+   specification of [elements] has an indirect impact on [fold],
+   which can now be proved to receive elements in increasing order. *)
+  End elt.
+End Sfun.
+
+
+
+(** ** Maps on ordered keys, self-contained signature *)
+
+Module Type S.
+  Declare Module E : OrderedType.
+  Include Sfun E.
+End S.
+
+
+
+(** ** Maps with ordering both on keys and datas *)
+
+Module Type Sord.
+
+  Declare Module Data : OrderedType.
+  Declare Module MapS : S.
+  Import MapS.
+
+  Definition t := MapS.t Data.t.
+
+  Parameter eq : t -> t -> Prop.
+  Parameter lt : t -> t -> Prop.
+
+  Axiom eq_refl : forall m : t, eq m m.
+  Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+  Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
+  Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
+  Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
+
+  Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end.
+
+  Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'.
+  Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'.
+
+  Parameter compare : forall m1 m2, Compare lt eq m1 m2.
+  (** Total ordering between maps. [Data.compare] is a total ordering
+      used to compare data associated with equal keys in the two maps. *)
+
+End Sord.
diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v
new file mode 100644
index 0000000000..335fdc3232
--- /dev/null
+++ b/theories/FSets/FMapList.v
@@ -0,0 +1,1339 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * Finite map library *)
+
+(** This file proposes an implementation of the non-dependent interface
+ [FMapInterface.S] using lists of pairs ordered (increasing) with respect to
+ left projection. *)
+
+Require Import FunInd FMapInterface.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module Raw (X:OrderedType).
+
+Module Import MX := OrderedTypeFacts X.
+Module Import PX := KeyOrderedType X.
+
+Definition key := X.t.
+Definition t (elt:Type) := list (X.t * elt).
+
+Section Elt.
+Variable elt : Type.
+
+Notation eqk := (eqk (elt:=elt)).
+Notation eqke := (eqke (elt:=elt)).
+Notation ltk := (ltk (elt:=elt)).
+Notation MapsTo := (MapsTo (elt:=elt)).
+Notation In := (In (elt:=elt)).
+Notation Sort := (sort ltk).
+Notation Inf := (lelistA (ltk)).
+
+(** * [empty] *)
+
+Definition empty : t elt := nil.
+
+Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.
+
+Lemma empty_1 : Empty empty.
+Proof.
+ unfold Empty,empty.
+ intros a e.
+ intro abs.
+ inversion abs.
+Qed.
+Hint Resolve empty_1 : core.
+
+Lemma empty_sorted : Sort empty.
+Proof.
+ unfold empty; auto.
+Qed.
+
+(** * [is_empty] *)
+
+Definition is_empty (l : t elt) : bool := if l then true else false.
+
+Lemma is_empty_1 :forall m, Empty m -> is_empty m = true.
+Proof.
+ unfold Empty, PX.MapsTo.
+ intros m.
+ case m;auto.
+ intros (k,e) l inlist.
+ absurd (InA eqke (k, e) ((k, e) :: l));auto.
+Qed.
+
+Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+Proof.
+ intros m.
+ case m;auto.
+ intros p l abs.
+ inversion abs.
+Qed.
+
+(** * [mem] *)
+
+Function mem (k : key) (s : t elt) {struct s} : bool :=
+ match s with
+  | nil => false
+  | (k',_) :: l =>
+     match X.compare k k' with
+      | LT _ => false
+      | EQ _ => true
+      | GT _ => mem k l
+     end
+ end.
+
+Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true.
+Proof.
+ intros m Hm x; generalize Hm; clear Hm.
+ functional induction (mem x m);intros sorted belong1;trivial.
+
+ inversion belong1. inversion H.
+
+ absurd (In x ((k', _x) :: l));try assumption.
+ apply Sort_Inf_NotIn with _x;auto.
+
+ apply IHb.
+ elim (sort_inv sorted);auto.
+ elim (In_inv belong1);auto.
+ intro abs.
+ absurd (X.eq x k');auto.
+Qed.
+
+Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m.
+Proof.
+ intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo.
+ functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail).
+ exists _x; auto.
+ induction IHb; auto.
+ exists x0; auto.
+ inversion_clear sorted; auto.
+Qed.
+
+(** * [find] *)
+
+Function find (k:key) (s: t elt) {struct s} : option elt :=
+ match s with
+  | nil => None
+  | (k',x)::s' =>
+     match X.compare k k' with
+      | LT _ => None
+      | EQ _ => Some x
+      | GT _ => find k s'
+     end
+ end.
+
+Lemma find_2 :  forall m x e, find x m = Some e -> MapsTo x e m.
+Proof.
+ intros m x. unfold PX.MapsTo.
+ functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto.
+Qed.
+
+Lemma find_1 :  forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e.
+Proof.
+ intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (find x m);simpl; subst; try clear H_eq_1.
+
+ inversion 2.
+
+ inversion_clear 2.
+ clear e1;compute in H0; destruct H0;order.
+ clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.
+
+ clear e1;inversion_clear 2.
+ compute in H0; destruct H0; intuition congruence.
+ generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order.
+
+ clear e1; do 2 inversion_clear 1; auto.
+ compute in H2; destruct H2; order.
+Qed.
+
+(** * [add] *)
+
+Function add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
+ match s with
+  | nil => (k,x) :: nil
+  | (k',y) :: l =>
+     match X.compare k k' with
+      | LT _ => (k,x)::s
+      | EQ _ => (k,x)::l
+      | GT _ => (k',y) :: add k x l
+     end
+ end.
+
+Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m).
+Proof.
+ intros m x y e; generalize y; clear y.
+ unfold PX.MapsTo.
+ functional induction (add x e m);simpl;auto.
+Qed.
+
+Lemma add_2 : forall m x y e e',
+  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+Proof.
+ intros m x  y e e'.
+ generalize y e; clear y e; unfold PX.MapsTo.
+ functional induction (add x e' m) ;simpl;auto;  clear e0.
+ subst;auto.
+
+ intros y' e'' eqky';  inversion_clear 1;  destruct H0; simpl in *.
+ order.
+ auto.
+ auto.
+ intros y' e'' eqky'; inversion_clear 1; intuition.
+Qed.
+
+
+Lemma add_3 : forall m x y e e',
+  ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+Proof.
+ intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo.
+ functional induction (add x e' m);simpl; intros.
+ apply (In_inv_3 H0); compute; auto.
+ apply (In_inv_3 H0); compute; auto.
+ constructor 2; apply (In_inv_3 H0); compute; auto.
+ inversion_clear H0; auto.
+Qed.
+
+
+Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt),
+  Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x'',e'').
+ inversion_clear H.
+ compute in H0,H1.
+ simpl; case (X.compare x x''); intuition.
+Qed.
+Hint Resolve add_Inf : core.
+
+Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x',e').
+ simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto.
+ constructor; auto.
+ apply Inf_eq with (x',e'); auto.
+Qed.
+
+(** * [remove] *)
+
+Function remove (k : key) (s : t elt) {struct s} : t elt :=
+ match s with
+  | nil => nil
+  | (k',x) :: l =>
+     match X.compare k k' with
+      | LT _ => s
+      | EQ _ => l
+      | GT _ => (k',x) :: remove k l
+     end
+ end.
+
+Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m).
+Proof.
+ intros m Hm x y; generalize Hm; clear Hm.
+ functional induction (remove x m);simpl;intros;subst.
+
+ red; inversion 1; inversion H1.
+
+ apply Sort_Inf_NotIn with x0; auto.
+ clear e0;constructor; compute; order.
+
+ clear e0;inversion_clear Hm.
+ apply Sort_Inf_NotIn with x0; auto.
+ apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto.
+
+ clear e0;inversion_clear Hm.
+ assert (notin:~ In y (remove x l)) by auto.
+ intros (x1,abs).
+ inversion_clear abs.
+ compute in H2; destruct H2; order.
+ apply notin; exists x1; auto.
+Qed.
+
+
+Lemma remove_2 : forall m (Hm:Sort m) x y e,
+  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (remove x m);subst;auto;
+   match goal with
+     | [H: X.compare _ _ = _ |- _ ] => clear H
+     | _ => idtac
+   end.
+
+ inversion_clear 3; auto.
+ compute in H1; destruct H1; order.
+
+ inversion_clear 1; inversion_clear 2; auto.
+Qed.
+
+Lemma remove_3 : forall m (Hm:Sort m) x y e,
+  MapsTo y e (remove x m) -> MapsTo y e m.
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (remove x m);subst;auto.
+ inversion_clear 1; inversion_clear 1; auto.
+Qed.
+
+Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt),
+  Inf (x',e') m -> Inf (x',e') (remove x m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x'',e'').
+ inversion_clear H.
+ compute in H0.
+ simpl; case (X.compare x x''); intuition.
+ inversion_clear Hm.
+ apply Inf_lt with (x'',e''); auto.
+Qed.
+Hint Resolve remove_Inf : core.
+
+Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x',e').
+ simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto.
+Qed.
+
+(** * [elements] *)
+
+Definition elements (m: t elt) := m.
+
+Lemma elements_1 : forall m x e,
+  MapsTo x e m -> InA eqke (x,e) (elements m).
+Proof.
+ auto.
+Qed.
+
+Lemma elements_2 : forall m x e,
+  InA eqke (x,e) (elements m) -> MapsTo x e m.
+Proof.
+ auto.
+Qed.
+
+Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m).
+Proof.
+ auto.
+Qed.
+
+Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m).
+Proof.
+ intros.
+ apply Sort_NoDupA.
+ apply elements_3; auto.
+Qed.
+
+(** * [fold] *)
+
+Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} :  A :=
+  match m with
+   | nil => acc
+   | (k,e)::m' => fold f m' (f k e acc)
+  end.
+
+Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A),
+  fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+Proof.
+ intros; functional induction (fold f m i); auto.
+Qed.
+
+(** * [equal] *)
+
+Function equal (cmp:elt->elt->bool)(m m' : t elt) {struct m} : bool :=
+  match m, m' with
+   | nil, nil => true
+   | (x,e)::l, (x',e')::l' =>
+      match X.compare x x' with
+       | EQ _ => cmp e e' && equal cmp l l'
+       | _    => false
+      end
+   | _, _ => false
+  end.
+
+Definition Equivb cmp m m' :=
+  (forall k, In k m <-> In k m') /\
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
+
+Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp,
+  Equivb cmp m m' -> equal cmp m m' = true.
+Proof.
+ intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
+ functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb;
+ intuition; subst.
+ match goal with H: X.compare _ _ = _ |- _ => clear H end.
+ assert (cmp_e_e':cmp e e' = true).
+  apply H1 with x; auto.
+ rewrite cmp_e_e'; simpl.
+ apply IHb; auto.
+ inversion_clear Hm; auto.
+ inversion_clear Hm'; auto.
+ unfold Equivb; intuition.
+ destruct (H0 k).
+ assert (In k ((x,e) ::l)).
+  destruct H as (e'', hyp); exists e''; auto.
+ destruct (In_inv (H2 H4)); auto.
+ inversion_clear Hm.
+ elim (Sort_Inf_NotIn H6 H7).
+ destruct H as (e'', hyp); exists e''; auto.
+ apply MapsTo_eq with k; auto; order.
+ destruct (H0 k).
+ assert (In k ((x',e') ::l')).
+  destruct H as (e'', hyp); exists e''; auto.
+ destruct (In_inv (H3 H4)); auto.
+ inversion_clear Hm'.
+ elim (Sort_Inf_NotIn H6 H7).
+ destruct H as (e'', hyp); exists e''; auto.
+ apply MapsTo_eq with k; auto; order.
+ apply H1 with k; destruct (X.eq_dec x k); auto.
+
+
+ destruct (X.compare x x') as [Hlt|Heq|Hlt]; try contradiction; clear y.
+ destruct (H0 x).
+ assert (In x ((x',e')::l')).
+  apply H; auto.
+  exists e; auto.
+ destruct (In_inv H3).
+ order.
+ inversion_clear Hm'.
+ assert (Inf (x,e) l').
+ apply Inf_lt with (x',e'); auto.
+ elim (Sort_Inf_NotIn H5 H7 H4).
+
+ destruct (H0 x').
+ assert (In x' ((x,e)::l)).
+  apply H2; auto.
+  exists e'; auto.
+ destruct (In_inv H3).
+ order.
+ inversion_clear Hm.
+ assert (Inf (x',e') l).
+  apply Inf_lt with (x,e); auto.
+ elim (Sort_Inf_NotIn H5 H7 H4).
+
+ destruct m;
+ destruct m';try contradiction.
+
+ clear H1;destruct p as (k,e).
+ destruct (H0 k).
+ destruct H1.
+ exists e; auto.
+ inversion H1.
+
+ destruct p as (x,e).
+ destruct (H0 x).
+ destruct H.
+ exists e; auto.
+ inversion H.
+
+ destruct p;destruct p0;contradiction.
+Qed.
+
+
+Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp,
+  equal cmp m m' = true -> Equivb cmp m m'.
+Proof.
+ intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'.
+ functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb;
+  intuition; try discriminate; subst;
+  try match goal with H: X.compare _ _ = _ |- _ => clear H end.
+
+ inversion H0.
+
+ inversion_clear Hm;inversion_clear Hm'.
+ destruct (andb_prop _ _ H); clear H.
+ destruct (IHb H1 H3 H6).
+ destruct (In_inv H0).
+ exists e'; constructor; split; trivial; apply X.eq_trans with x; auto.
+ destruct (H k).
+ destruct (H9 H8) as (e'',hyp).
+ exists e''; auto.
+
+ inversion_clear Hm;inversion_clear Hm'.
+ destruct (andb_prop _ _ H); clear H.
+ destruct (IHb H1 H3 H6).
+ destruct (In_inv H0).
+ exists e; constructor; split; trivial; apply X.eq_trans with x'; auto.
+ destruct (H k).
+ destruct (H10 H8) as (e'',hyp).
+ exists e''; auto.
+
+ inversion_clear Hm;inversion_clear Hm'.
+ destruct (andb_prop _ _ H); clear H.
+ destruct (IHb H2 H4 H7).
+ inversion_clear H0.
+ destruct H9; simpl in *; subst.
+ inversion_clear H1.
+ destruct H9; simpl in *; subst; auto.
+ elim (Sort_Inf_NotIn H4 H5).
+ exists e'0; apply MapsTo_eq with k; auto; order.
+ inversion_clear H1.
+ destruct H0; simpl in *; subst; auto.
+ elim (Sort_Inf_NotIn H2 H3).
+ exists e0; apply MapsTo_eq with k; auto; order.
+ apply H8 with k; auto.
+Qed.
+
+(** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *)
+
+Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) ->
+  eqk x y -> cmp (snd x) (snd y) = true ->
+  (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)).
+Proof.
+ intros.
+ inversion H; subst.
+ inversion H0; subst.
+ destruct x; destruct y; compute in H1, H2.
+ split; intros.
+ apply equal_2; auto.
+ simpl.
+ elim_comp.
+ rewrite H2; simpl.
+ apply equal_1; auto.
+ apply equal_2; auto.
+ generalize (equal_1 H H0 H3).
+ simpl.
+ elim_comp.
+ rewrite H2; simpl; auto.
+Qed.
+
+Variable elt':Type.
+
+(** * [map] and [mapi] *)
+
+Fixpoint map (f:elt -> elt') (m:t elt) : t elt' :=
+  match m with
+   | nil => nil
+   | (k,e)::m' => (k,f e) :: map f m'
+  end.
+
+Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' :=
+  match m with
+   | nil => nil
+   | (k,e)::m' => (k,f k e) :: mapi f m'
+  end.
+ 
+End Elt.
+Section Elt2.
+(* A new section is necessary for previous definitions to work
+   with different [elt], especially [MapsTo]... *)
+
+Variable elt elt' : Type.
+
+(** Specification of [map] *)
+
+Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'),
+  MapsTo x e m -> MapsTo x (f e) (map f m).
+Proof.
+ intros m x e f.
+ (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
+ induction m.
+ inversion 1. 
+
+ destruct a as (x',e').
+ simpl.
+ inversion_clear 1.  
+ constructor 1.
+ unfold eqke in *; simpl in *; intuition congruence.
+ unfold MapsTo in *; auto.
+Qed.
+
+Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'),
+  In x (map f m) -> In x m.
+Proof.
+ intros m x f.
+ (* functional induction map elt elt' f m. *) (* Marche pas ??? *)
+ induction m; simpl.
+ intros (e,abs).
+ inversion abs.
+
+ destruct a as (x',e).
+ intros hyp.
+ inversion hyp. clear hyp.
+ inversion H; subst; rename x0 into e'.
+ exists e; constructor.
+ unfold eqke in *; simpl in *; intuition.
+ destruct IHm as (e'',hyp).
+ exists e'; auto.
+ exists e''.
+ constructor 2; auto.
+Qed.
+
+Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'),
+  lelistA (@ltk elt) (x,e) m ->
+  lelistA (@ltk elt') (x,e') (map f m).
+Proof.
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x0,e0).
+ inversion_clear H; auto.
+Qed.
+
+Hint Resolve map_lelistA : core.
+
+Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'),
+  sort (@ltk elt') (map f m).
+Proof.
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm.
+ constructor; auto.
+ exact (map_lelistA _ _ H0).
+Qed.
+
+(** Specification of [mapi] *)
+
+Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'),
+  MapsTo x e m ->
+  exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
+Proof.
+ intros m x e f.
+ (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
+ induction m.
+ inversion 1.
+
+ destruct a as (x',e').
+ simpl.
+ inversion_clear 1.
+ exists x'.
+ destruct H0; simpl in *.
+ split; auto.
+ constructor 1.
+ unfold eqke in *; simpl in *; intuition congruence.
+ destruct IHm as (y, hyp); auto.
+ exists y; intuition.
+Qed.
+
+
+Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'),
+  In x (mapi f m) -> In x m.
+Proof.
+ intros m x f.
+ (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
+ induction m; simpl.
+ intros (e,abs).
+ inversion abs.
+
+ destruct a as (x',e).
+ intros hyp.
+ inversion hyp. clear hyp.
+ inversion H; subst; rename x0 into e'.
+ exists e; constructor.
+ unfold eqke in *; simpl in *; intuition.
+ destruct IHm as (e'',hyp).
+ exists e'; auto.
+ exists e''.
+ constructor 2; auto.
+Qed.
+
+Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
+  lelistA (@ltk elt) (x,e) m ->
+  lelistA (@ltk elt') (x,f x e) (mapi f m).
+Proof.
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear H; auto.
+Qed.
+
+Hint Resolve mapi_lelistA : core.
+
+Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'),
+  sort (@ltk elt') (mapi f m).
+Proof.
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm; auto.
+Qed.
+
+End Elt2.
+Section Elt3.
+
+(** * [map2] *)
+
+Variable elt elt' elt'' : Type.
+Variable f : option elt -> option elt' -> option elt''.
+
+Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) :=
+  match o with
+   | Some e => (k,e)::l
+   | None => l
+  end.
+
+Fixpoint map2_l (m : t elt) : t elt'' :=
+  match m with
+   | nil => nil
+   | (k,e)::l => option_cons k (f (Some e) None) (map2_l l)
+  end.
+
+Fixpoint map2_r (m' : t elt') : t elt'' :=
+  match m' with
+   | nil => nil
+   | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l')
+  end.
+
+Fixpoint map2 (m : t elt) : t elt' -> t elt'' :=
+  match m with
+   | nil => map2_r
+   | (k,e) :: l =>
+      fix map2_aux (m' : t elt') : t elt'' :=
+        match m' with
+         | nil => map2_l m
+         | (k',e') :: l' =>
+            match X.compare k k' with
+             | LT _ => option_cons k (f (Some e) None) (map2 l m')
+             | EQ _ => option_cons k (f (Some e) (Some e')) (map2 l l')
+             | GT _ => option_cons k' (f None (Some e')) (map2_aux l')
+            end
+        end
+  end.
+
+Notation oee' := (option elt * option elt')%type.
+
+Fixpoint combine (m : t elt) : t elt' -> t oee' :=
+  match m with
+   | nil => map (fun e' => (None,Some e'))
+   | (k,e) :: l =>
+      fix combine_aux (m':t elt') : list (key * oee') :=
+        match m' with
+         | nil => map (fun e => (Some e,None)) m
+         | (k',e') :: l' =>
+            match X.compare k k' with
+             | LT _ => (k,(Some e, None))::combine l m'
+             | EQ _ => (k,(Some e, Some e'))::combine l l'
+             | GT _ => (k',(None,Some e'))::combine_aux l'
+            end
+        end
+  end.
+
+Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) :=
+  List.fold_right (fun p => f (fst p) (snd p)) i l.
+
+Definition map2_alt m m' :=
+  let m0 : t oee' := combine m m' in
+  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in
+  fold_right_pair (option_cons (A:=elt'')) m1 nil.
+
+Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'.
+Proof.
+ unfold map2_alt.
+ induction m.
+ simpl; auto; intros.
+ (* map2_r *)
+ induction m'; try destruct a; simpl; auto.
+ rewrite IHm'; auto.
+ (* fin map2_r *)
+ induction m'; destruct a.
+ simpl; f_equal.
+ (* map2_l *)
+ clear IHm.
+ induction m; try destruct a; simpl; auto.
+ rewrite IHm; auto.
+ (* fin map2_l *)
+ destruct a0.
+ simpl.
+ destruct (X.compare t0 t1); simpl; f_equal.
+ apply IHm.
+ apply IHm.
+ apply IHm'.
+Qed.
+
+Lemma combine_lelistA :
+  forall m m' (x:key)(e:elt)(e':elt')(e'':oee'),
+  lelistA (@ltk elt) (x,e) m ->
+  lelistA (@ltk elt') (x,e') m' ->
+  lelistA (@ltk oee') (x,e'') (combine m m').
+Proof.
+ induction m.
+ intros.
+ simpl.
+ exact (map_lelistA _ _ H0).
+ induction m'.
+ intros.
+ destruct a.
+ replace (combine ((t0, e0) :: m) nil) with
+             (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto.
+ exact (map_lelistA _ _ H).
+ intros.
+ simpl.
+ destruct a as (k,e0); destruct a0 as (k',e0').
+ destruct (X.compare k k').
+ inversion_clear H; auto.
+ inversion_clear H; auto.
+ inversion_clear H0; auto.
+Qed.
+Hint Resolve combine_lelistA : core.
+
+Lemma combine_sorted :
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'),
+  sort (@ltk oee') (combine m m').
+Proof.
+ induction m.
+ intros; clear Hm.
+ simpl.
+ apply map_sorted; auto.
+ induction m'.
+ intros; clear Hm'.
+ destruct a.
+ replace (combine ((t0, e) :: m) nil) with
+             (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto.
+ apply map_sorted; auto.
+ intros.
+ simpl.
+ destruct a as (k,e); destruct a0 as (k',e').
+ destruct (X.compare k k') as [Hlt|Heq|Hlt].
+ inversion_clear Hm.
+ constructor; auto.
+ assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto.
+ exact (combine_lelistA _ H0 H1).
+ inversion_clear Hm; inversion_clear Hm'.
+ constructor; auto.
+ assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto).
+ exact (combine_lelistA _ H0 H3).
+ inversion_clear Hm; inversion_clear Hm'.
+ constructor; auto.
+ change (lelistA (ltk (elt:=oee')) (k', (None, Some e'))
+                 (combine ((k,e)::m) m')).
+ assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto.
+ exact (combine_lelistA _  H3 H2).
+Qed.
+
+Lemma map2_sorted :
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'),
+  sort (@ltk elt'') (map2 m m').
+Proof.
+ intros.
+ rewrite <- map2_alt_equiv.
+ unfold map2_alt.
+ assert (H0:=combine_sorted Hm Hm').
+ set (l0:=combine m m') in *; clearbody l0.
+ set (f':= fun p : oee' => f (fst p) (snd p)).
+ assert (H1:=map_sorted (elt' := option elt'') H0 f').
+ set (l1:=map f' l0) in *; clearbody l1.
+ clear f' f H0 l0 Hm Hm' m m'.
+ induction l1.
+ simpl; auto.
+ inversion_clear H1.
+ destruct a; destruct o; auto.
+ simpl.
+ constructor; auto.
+ clear IHl1.
+ induction l1.
+ simpl; auto.
+ destruct a; destruct o; simpl; auto.
+ inversion_clear H0; auto.
+ inversion_clear H0.
+ red in H1; simpl in H1.
+ inversion_clear H.
+ apply IHl1; auto.
+ apply Inf_lt with (t1, None (A:=elt'')); auto.
+Qed.
+
+Definition at_least_one (o:option elt)(o':option elt') :=
+  match o, o' with
+   | None, None => None
+   | _, _  => Some (o,o')
+  end.
+
+Lemma combine_1 :
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key),
+  find x (combine m m') = at_least_one (find x m) (find x m').
+Proof.
+ induction m.
+ intros.
+ simpl.
+ induction m'.
+ intros; simpl; auto.
+ simpl; destruct a.
+ simpl; destruct (X.compare x t0); simpl; auto.
+ inversion_clear Hm'; auto.
+ induction m'.
+ (* m' = nil *)
+ intros; destruct a; simpl.
+ destruct (X.compare x t0) as [Hlt| |Hlt]; simpl; auto.
+ inversion_clear Hm; clear H0 Hlt Hm' IHm t0.
+ induction m; simpl; auto.
+ inversion_clear H.
+ destruct a.
+ simpl; destruct (X.compare x t0); simpl; auto.
+ (* m' <> nil *)
+ intros.
+ destruct a as (k,e); destruct a0 as (k',e'); simpl.
+ inversion Hm; inversion Hm'; subst.
+ destruct (X.compare k k'); simpl;
+  destruct (X.compare x k);
+   elim_comp || destruct (X.compare x k'); simpl; auto.
+ rewrite IHm; auto; simpl; elim_comp; auto.
+ rewrite IHm; auto; simpl; elim_comp; auto.
+ rewrite IHm; auto; simpl; elim_comp; auto.
+ change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')).
+ rewrite IHm'; auto.
+ simpl find; elim_comp; auto.
+ change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')).
+ rewrite IHm'; auto.
+ simpl find; elim_comp; auto.
+ change (find x (combine ((k, e) :: m) m') =
+         at_least_one (find x m) (find x m')).
+ rewrite IHm'; auto.
+ simpl find; elim_comp; auto.
+Qed.
+
+Definition at_least_one_then_f (o:option elt)(o':option elt') :=
+  match o, o' with
+   | None, None => None
+   | _, _  => f o o'
+  end.
+
+Lemma map2_0 :
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key),
+  find x (map2 m m') = at_least_one_then_f (find x m) (find x m').
+Proof.
+ intros.
+ rewrite <- map2_alt_equiv.
+ unfold map2_alt.
+ assert (H:=combine_1 Hm Hm' x).
+ assert (H2:=combine_sorted Hm Hm').
+ set (f':= fun p : oee' => f (fst p) (snd p)).
+ set (m0 := combine m m') in *; clearbody m0.
+ set (o:=find x m) in *; clearbody o.
+ set (o':=find x m') in *; clearbody o'.
+ clear Hm Hm' m m'.
+ generalize H; clear H.
+ match goal with |- ?m=?n -> ?p=?q =>
+   assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end.
+ induction m0; simpl in *; intuition.
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ destruct a as (k,(oo,oo')); simpl in *.
+ inversion_clear H2.
+ destruct (X.compare x k) as [Hlt|Heq|Hlt]; simpl in *.
+ (* x < k *)
+ destruct (f' (oo,oo')); simpl.
+ elim_comp.
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ destruct (IHm0 H0) as (H2,_); apply H2; auto.
+ rewrite <- H.
+ case_eq (find x m0); intros; auto.
+ assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
+  red; auto.
+ destruct (Sort_Inf_NotIn H0 (Inf_lt H4 H1)).
+ exists p; apply find_2; auto.
+ (* x = k *)
+ assert (at_least_one_then_f o o' = f oo oo').
+  destruct o; destruct o'; simpl in *; inversion_clear H; auto.
+ rewrite H2.
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ elim_comp; auto.
+ destruct (IHm0 H0) as (_,H4); apply H4; auto.
+ case_eq (find x m0); intros; auto.
+ assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))).
+  red; auto.
+ destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)).
+ exists p; apply find_2; auto.
+ (* k < x *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ elim_comp; auto.
+ destruct (IHm0 H0) as (H3,_); apply H3; auto.
+ destruct (IHm0 H0) as (H3,_); apply H3; auto.
+
+ (* None -> None *)
+ destruct a as (k,(oo,oo')).
+ simpl.
+ inversion_clear H2.
+ destruct (X.compare x k) as [Hlt|Heq|Hlt].
+ (* x < k *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ elim_comp; auto.
+ destruct (IHm0 H0) as (_,H4); apply H4; auto.
+ case_eq (find x m0); intros; auto.
+ assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
+  red; auto.
+ destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)).
+ exists p; apply find_2; auto.
+ (* x = k *)
+ discriminate.
+ (* k < x *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ elim_comp; auto.
+ destruct (IHm0 H0) as (_,H4); apply H4; auto.
+ destruct (IHm0 H0) as (_,H4); apply H4; auto.
+Qed.
+
+(** Specification of [map2] *)
+
+Lemma map2_1 :
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key),
+  In x m \/ In x m' ->
+  find x (map2 m m') = f (find x m) (find x m').
+Proof.
+ intros.
+ rewrite map2_0; auto.
+ destruct H as [(e,H)|(e,H)].
+ rewrite (find_1 Hm H).
+ destruct (find x m'); simpl; auto.
+ rewrite (find_1 Hm' H).
+ destruct (find x m); simpl; auto.
+Qed.
+
+Lemma map2_2 :
+  forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key),
+  In x (map2 m m') -> In x m \/ In x m'.
+Proof.
+ intros.
+ destruct H as (e,H).
+ generalize (map2_0 Hm Hm' x).
+ rewrite (find_1 (map2_sorted Hm Hm') H).
+ generalize (@find_2 _ m x).
+ generalize (@find_2 _ m' x).
+ destruct (find x m);
+   destruct (find x m'); simpl; intros.
+ left; exists e0; auto.
+ left; exists e0; auto.
+ right; exists e0; auto.
+ discriminate.
+Qed.
+
+End Elt3.
+End Raw.
+
+Module Make (X: OrderedType) <: S with Module E := X.
+Module Raw := Raw X.
+Module E := X.
+
+Definition key := E.t.
+
+#[universes(template)]
+Record slist (elt:Type) :=
+  {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}.
+Definition t (elt:Type) : Type := slist elt.
+
+Section Elt.
+ Variable elt elt' elt'':Type.
+
+ Implicit Types m : t elt.
+ Implicit Types x y : key.
+ Implicit Types e : elt.
+
+ Definition empty : t elt := Build_slist (Raw.empty_sorted elt).
+ Definition is_empty m : bool := Raw.is_empty (this m).
+ Definition add x e m : t elt := Build_slist (Raw.add_sorted (sorted m) x e).
+ Definition find x m : option elt := Raw.find x (this m).
+ Definition remove x m : t elt := Build_slist (Raw.remove_sorted (sorted m) x).
+ Definition mem x m : bool := Raw.mem x (this m).
+ Definition map f m : t elt' := Build_slist (Raw.map_sorted (sorted m) f).
+ Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted (sorted m) f).
+ Definition map2 f m (m':t elt') : t elt'' :=
+   Build_slist (Raw.map2_sorted f (sorted m) (sorted m')).
+ Definition elements m : list (key*elt) := @Raw.elements elt (this m).
+ Definition cardinal m := length (this m).
+ Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i.
+ Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m').
+
+ Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m).
+ Definition In x m : Prop := Raw.PX.In x (this m).
+ Definition Empty m : Prop := Raw.Empty (this m).
+
+ Definition Equal m m' := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+         (forall k, In k m <-> In k m') /\
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+ Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m').
+
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt.
+ Definition lt_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.ltk elt.
+
+ Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed.
+
+ Lemma mem_1 : forall m x, In x m -> mem x m = true.
+ Proof. intros m; exact (@Raw.mem_1 elt (this m) (sorted m)). Qed.
+ Lemma mem_2 : forall m x, mem x m = true -> In x m.
+ Proof. intros m; exact (@Raw.mem_2 elt (this m) (sorted m)). Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact (@Raw.empty_1 elt). Qed.
+
+ Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
+ Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed.
+ Lemma is_empty_2 :  forall m, is_empty m = true -> Empty m.
+ Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed.
+
+ Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
+ Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed.
+ Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+ Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed.
+ Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed.
+
+ Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
+ Proof. intros m; exact (@Raw.remove_1 elt (this m) (sorted m)). Qed.
+ Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+ Proof. intros m; exact (@Raw.remove_2 elt (this m) (sorted m)). Qed.
+ Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.remove_3 elt (this m) (sorted m)). Qed.
+
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
+ Proof. intros m; exact (@Raw.find_1 elt (this m) (sorted m)). Qed.
+ Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed.
+
+ Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+ Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed.
+ Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed.
+ Lemma elements_3 : forall m, sort lt_key (elements m).
+ Proof. intros m; exact (@Raw.elements_3 elt (this m) (sorted m)). Qed.
+ Lemma elements_3w : forall m, NoDupA eq_key (elements m).
+ Proof. intros m; exact (@Raw.elements_3w elt (this m) (sorted m)). Qed.
+
+ Lemma cardinal_1 : forall m, cardinal m = length (elements m).
+ Proof. intros; reflexivity. Qed.
+
+ Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+ Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed.
+
+ Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true.
+ Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (sorted m) (this m') (sorted m')). Qed.
+ Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'.
+ Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (sorted m) (this m') (sorted m')). Qed.
+
+ End Elt.
+
+ Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+ Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed.
+ Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
+        In x (map f m) -> In x m.
+ Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed.
+
+ Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m ->
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+ Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed.
+ Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+ Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed.
+
+ Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''),
+	In x m \/ In x m' ->
+        find x (map2 f m m') = f (find x m) (find x m').
+ Proof.
+ intros elt elt' elt'' m m' x f;
+ exact (@Raw.map2_1 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x).
+ Qed.
+ Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''),
+        In x (map2 f m m') -> In x m \/ In x m'.
+ Proof.
+ intros elt elt' elt'' m m' x f;
+ exact (@Raw.map2_2 elt elt' elt'' f (this m) (sorted m) (this m') (sorted m') x).
+ Qed.
+
+End Make.
+
+Module Make_ord (X: OrderedType)(D : OrderedType) <:
+Sord with Module Data := D
+        with Module MapS.E := X.
+
+Module Data := D.
+Module MapS := Make(X).
+Import MapS.
+
+Module MD := OrderedTypeFacts(D).
+Import MD.
+
+Definition t := MapS.t D.t.
+
+Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end.
+
+Fixpoint eq_list (m m' : list (X.t * D.t)) : Prop :=
+  match m, m' with
+   | nil, nil => True
+   | (x,e)::l, (x',e')::l' =>
+      match X.compare x x' with
+       | EQ _ => D.eq e e' /\ eq_list l l'
+       | _       => False
+      end
+   | _, _ => False
+  end.
+
+Definition eq m m' := eq_list (this m) (this m').
+
+Fixpoint lt_list (m m' : list (X.t * D.t)) : Prop :=
+  match m, m' with
+   | nil, nil => False
+   | nil, _  => True
+   | _, nil  => False
+   | (x,e)::l, (x',e')::l' =>
+      match X.compare x x' with
+       | LT _ => True
+       | GT _ => False
+       | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l')
+      end
+  end.
+
+Definition lt m m' := lt_list (this m) (this m').
+
+Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true.
+Proof.
+ intros (l,Hl); induction l.
+ intros (l',Hl'); unfold eq; simpl.
+ destruct l'; unfold equal; simpl; intuition.
+ intros (l',Hl'); unfold eq.
+ destruct l'.
+ destruct a; unfold equal; simpl; intuition.
+ destruct a as (x,e).
+ destruct p as (x',e').
+ unfold equal; simpl.
+ destruct (X.compare x x') as [Hlt|Heq|Hlt]; simpl; intuition.
+ unfold cmp at 1.
+ MD.elim_comp; clear H; simpl.
+ inversion_clear Hl.
+ inversion_clear Hl'.
+ destruct (IHl H (Build_slist H3)).
+ unfold equal, eq in H5; simpl in H5; auto.
+ destruct (andb_prop _ _ H); clear H.
+ generalize H0; unfold cmp.
+ MD.elim_comp; auto; intro; discriminate.
+ destruct (andb_prop _ _ H); clear H.
+ inversion_clear Hl.
+ inversion_clear Hl'.
+ destruct (IHl H (Build_slist H3)).
+ unfold equal, eq in H6; simpl in H6; auto.
+Qed.
+
+Lemma eq_1 : forall m m', Equivb cmp m m' -> eq m m'.
+Proof.
+ intros.
+ generalize (@equal_1 D.t m m' cmp).
+ generalize (@eq_equal m m').
+ intuition.
+Qed.
+
+Lemma eq_2 : forall m m', eq m m' -> Equivb cmp m m'.
+Proof.
+ intros.
+ generalize (@equal_2 D.t m m' cmp).
+ generalize (@eq_equal m m').
+ intuition.
+Qed.
+
+Lemma eq_refl : forall m : t, eq m m.
+Proof.
+ intros (m,Hm); induction m; unfold eq; simpl; auto.
+ destruct a.
+ destruct (X.compare t0 t0) as [Hlt|Heq|Hlt]; auto.
+ apply (MapS.Raw.MX.lt_antirefl Hlt); auto.
+ split.
+ apply D.eq_refl.
+ inversion_clear Hm.
+ apply (IHm H).
+ apply (MapS.Raw.MX.lt_antirefl Hlt); auto.
+Qed.
+
+Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
+Proof.
+ intros (m,Hm); induction m;
+ intros (m', Hm'); destruct m'; unfold eq; simpl;
+ try destruct a as (x,e); try destruct p as (x',e'); auto.
+ destruct (X.compare x x')  as [Hlt|Heq|Hlt]; MapS.Raw.MX.elim_comp; intuition.
+ inversion_clear Hm; inversion_clear Hm'.
+ apply (IHm H0 (Build_slist H4)); auto.
+Qed.
+
+Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
+Proof.
+ intros (m1,Hm1); induction m1;
+ intros (m2, Hm2); destruct m2;
+ intros (m3, Hm3); destruct m3; unfold eq; simpl;
+ try destruct a as (x,e);
+ try destruct p as (x',e');
+ try destruct p0 as (x'',e''); try contradiction; auto.
+ destruct (X.compare x x') as [Hlt|Heq|Hlt];
+  destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt'];
+   MapS.Raw.MX.elim_comp; intuition.
+ apply D.eq_trans with e'; auto.
+ inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
+ apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition.
+Qed.
+
+Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
+Proof.
+ intros (m1,Hm1); induction m1;
+ intros (m2, Hm2); destruct m2;
+ intros (m3, Hm3); destruct m3; unfold lt; simpl;
+ try destruct a as (x,e);
+ try destruct p as (x',e');
+ try destruct p0 as (x'',e''); try contradiction; auto.
+ destruct (X.compare x x') as [Hlt|Heq|Hlt];
+  destruct (X.compare x' x'') as [Hlt'|Heq'|Hlt'];
+   MapS.Raw.MX.elim_comp; intuition.
+ left; apply D.lt_trans with e'; auto.
+ left; apply lt_eq with e'; auto.
+ left; apply eq_lt with e'; auto.
+ right.
+ split.
+ apply D.eq_trans with e'; auto.
+ inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
+ apply (IHm1 H2 (Build_slist H6) (Build_slist H8)); intuition.
+Qed.
+
+Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.
+Proof.
+ intros (m1,Hm1); induction m1;
+ intros (m2, Hm2); destruct m2; unfold eq, lt; simpl;
+ try destruct a as (x,e);
+ try destruct p as (x',e'); try contradiction; auto.
+ destruct (X.compare x x') as [Hlt|Heq|Hlt]; auto.
+ intuition.
+ exact (D.lt_not_eq H0 H1).
+ inversion_clear Hm1; inversion_clear Hm2.
+ apply (IHm1 H0 (Build_slist H5)); intuition.
+Qed.
+
+Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto.
+
+Definition compare : forall m1 m2, Compare lt eq m1 m2.
+Proof.
+ intros (m1,Hm1); induction m1;
+ intros (m2, Hm2); destruct m2;
+  [ apply EQ | apply LT | apply GT | ]; cmp_solve.
+ destruct a as (x,e); destruct p as (x',e').
+ destruct (X.compare x x');
+  [ apply LT | | apply GT ]; cmp_solve.
+ destruct (D.compare e e');
+  [ apply LT | | apply GT ]; cmp_solve.
+ assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1).
+  inversion_clear Hm1; auto.
+ assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2).
+  inversion_clear Hm2; auto.
+ destruct (IHm1 Hm11 (Build_slist Hm22));
+  [ apply LT | apply EQ | apply GT ]; cmp_solve.
+Qed.
+
+End Make_ord.
diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v
new file mode 100644
index 0000000000..b47c99244b
--- /dev/null
+++ b/theories/FSets/FMapPositive.v
@@ -0,0 +1,1123 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * FMapPositive : an implementation of FMapInterface for [positive] keys. *)
+
+Require Import Bool OrderedType ZArith OrderedType OrderedTypeEx FMapInterface.
+
+Set Implicit Arguments.
+Local Open Scope positive_scope.
+Local Unset Elimination Schemes.
+
+(** This file is an adaptation to the [FMap] framework of a work by
+  Xavier Leroy and Sandrine Blazy (used for building certified compilers).
+  Keys are of type [positive], and maps are binary trees: the sequence
+  of binary digits of a positive number corresponds to a path in such a tree.
+  This is quite similar to the [IntMap] library, except that no path
+  compression is implemented, and that the current file is simple enough to be
+  self-contained. *)
+
+(** First, some stuff about [positive] *)
+
+Fixpoint append (i j : positive) : positive :=
+    match i with
+      | xH => j
+      | xI ii => xI (append ii j)
+      | xO ii => xO (append ii j)
+    end.
+
+Lemma append_assoc_0 :
+  forall (i j : positive), append i (xO j) = append (append i (xO xH)) j.
+Proof.
+ induction i; intros; destruct j; simpl;
+ try rewrite (IHi (xI j));
+ try rewrite (IHi (xO j));
+ try rewrite <- (IHi xH);
+ auto.
+Qed.
+
+Lemma append_assoc_1 :
+  forall (i j : positive), append i (xI j) = append (append i (xI xH)) j.
+Proof.
+ induction i; intros; destruct j; simpl;
+ try rewrite (IHi (xI j));
+ try rewrite (IHi (xO j));
+ try rewrite <- (IHi xH);
+ auto.
+Qed.
+
+Lemma append_neutral_r : forall (i : positive), append i xH = i.
+Proof.
+ induction i; simpl; congruence.
+Qed.
+
+Lemma append_neutral_l : forall (i : positive), append xH i = i.
+Proof.
+ simpl; auto.
+Qed.
+
+
+(** The module of maps over positive keys *)
+
+Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits.
+
+  Module E:=PositiveOrderedTypeBits.
+  Module ME:=KeyOrderedType E.
+
+  Definition key := positive : Type. 
+
+  #[universes(template)]
+  Inductive tree (A : Type) :=
+    | Leaf : tree A
+    | Node : tree A -> option A -> tree A -> tree A.
+
+  Scheme tree_ind := Induction for tree Sort Prop.
+
+  Definition t := tree.
+
+  Section A.
+  Variable A:Type.
+
+  Arguments Leaf {A}.
+
+  Definition empty : t A := Leaf.
+
+  Fixpoint is_empty (m : t A) : bool :=
+   match m with
+    | Leaf => true
+    | Node l None r => (is_empty l) && (is_empty r)
+    | _ => false
+   end.
+
+  Fixpoint find (i : key) (m : t A) : option A :=
+    match m with
+    | Leaf => None
+    | Node l o r =>
+        match i with
+        | xH => o
+        | xO ii => find ii l
+        | xI ii => find ii r
+        end
+    end.
+
+  Fixpoint mem (i : key) (m : t A) : bool :=
+    match m with
+    | Leaf => false
+    | Node l o r =>
+        match i with
+        | xH => match o with None => false | _ => true end
+        | xO ii => mem ii l
+        | xI ii => mem ii r
+        end
+    end.
+
+  Fixpoint add (i : key) (v : A) (m : t A) : t A :=
+    match m with
+    | Leaf =>
+        match i with
+        | xH => Node Leaf (Some v) Leaf
+        | xO ii => Node (add ii v Leaf) None Leaf
+        | xI ii => Node Leaf None (add ii v Leaf)
+        end
+    | Node l o r =>
+        match i with
+        | xH => Node l (Some v) r
+        | xO ii => Node (add ii v l) o r
+        | xI ii => Node l o (add ii v r)
+        end
+    end.
+
+  Fixpoint remove (i : key) (m : t A) : t A :=
+    match i with
+    | xH =>
+        match m with
+        | Leaf => Leaf
+        | Node Leaf o Leaf => Leaf
+        | Node l o r => Node l None r
+        end
+    | xO ii =>
+        match m with
+        | Leaf => Leaf
+        | Node l None Leaf =>
+            match remove ii l with
+            | Leaf => Leaf
+            | mm => Node mm None Leaf
+            end
+        | Node l o r => Node (remove ii l) o r
+        end
+    | xI ii =>
+        match m with
+        | Leaf => Leaf
+        | Node Leaf None r =>
+            match remove ii r with
+            | Leaf => Leaf
+            | mm => Node Leaf None mm
+            end
+        | Node l o r => Node l o (remove ii r)
+        end
+    end.
+
+  (** [elements] *)
+
+    Fixpoint xelements (m : t A) (i : key) : list (key * A) :=
+      match m with
+      | Leaf => nil
+      | Node l None r =>
+          (xelements l (append i (xO xH))) ++ (xelements r (append i (xI xH)))
+      | Node l (Some x) r =>
+          (xelements l (append i (xO xH)))
+          ++ ((i, x) :: xelements r (append i (xI xH)))
+      end.
+
+  (* Note: function [xelements] above is inefficient.  We should apply
+     deforestation to it, but that makes the proofs even harder. *)
+
+  Definition elements (m : t A) := xelements m xH.
+
+  (** [cardinal] *)
+
+  Fixpoint cardinal (m : t A) : nat :=
+    match m with
+      | Leaf => 0%nat
+      | Node l None r => (cardinal l + cardinal r)%nat
+      | Node l (Some _) r => S (cardinal l + cardinal r)
+    end.
+
+  Section CompcertSpec.
+
+  Theorem gempty:
+    forall (i: key), find i empty = None.
+  Proof.
+    destruct i; simpl; auto.
+  Qed.
+
+  Theorem gss:
+    forall (i: key) (x: A) (m: t A), find i (add i x m) = Some x.
+  Proof.
+    induction i; destruct m; simpl; auto.
+  Qed.
+
+  Lemma gleaf : forall (i : key), find i (Leaf : t A) = None.
+  Proof. exact gempty. Qed.
+
+  Theorem gso:
+    forall (i j: key) (x: A) (m: t A),
+    i <> j -> find i (add j x m) = find i m.
+  Proof.
+    induction i; intros; destruct j; destruct m; simpl;
+       try rewrite <- (gleaf i); auto; try apply IHi; congruence.
+  Qed.
+
+  Lemma rleaf : forall (i : key), remove i Leaf = Leaf.
+  Proof. destruct i; simpl; auto. Qed.
+
+  Theorem grs:
+    forall (i: key) (m: t A), find i (remove i m) = None.
+  Proof.
+    induction i; destruct m.
+     simpl; auto.
+     destruct m1; destruct o; destruct m2 as [ | ll oo rr]; simpl; auto.
+      rewrite (rleaf i); auto.
+      cut (find i (remove i (Node ll oo rr)) = None).
+        destruct (remove i (Node ll oo rr)); auto; apply IHi.
+        apply IHi.
+     simpl; auto.
+     destruct m1 as [ | ll oo rr]; destruct o; destruct m2; simpl; auto.
+      rewrite (rleaf i); auto.
+      cut (find i (remove i (Node ll oo rr)) = None).
+        destruct (remove i (Node ll oo rr)); auto; apply IHi.
+        apply IHi.
+     simpl; auto.
+     destruct m1; destruct m2; simpl; auto.
+  Qed.
+
+  Theorem gro:
+    forall (i j: key) (m: t A),
+    i <> j -> find i (remove j m) = find i m.
+  Proof.
+    induction i; intros; destruct j; destruct m;
+        try rewrite (rleaf (xI j));
+        try rewrite (rleaf (xO j));
+        try rewrite (rleaf 1); auto;
+        destruct m1; destruct o; destruct m2;
+        simpl;
+        try apply IHi; try congruence;
+        try rewrite (rleaf j); auto;
+        try rewrite (gleaf i); auto.
+     cut (find i (remove j (Node m2_1 o m2_2)) = find i (Node m2_1 o m2_2));
+        [ destruct (remove j (Node m2_1 o m2_2)); try rewrite (gleaf i); auto
+        | apply IHi; congruence ].
+     destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i);
+        auto.
+     destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i);
+        auto.
+     cut (find i (remove j (Node m1_1 o0 m1_2)) = find i (Node m1_1 o0 m1_2));
+        [ destruct (remove j (Node m1_1 o0 m1_2)); try rewrite (gleaf i); auto
+        | apply IHi; congruence ].
+     destruct (remove j (Node m2_1 o m2_2)); simpl; try rewrite (gleaf i);
+        auto.
+     destruct (remove j (Node m1_1 o0 m1_2)); simpl; try rewrite (gleaf i);
+        auto.
+  Qed.
+
+  Lemma xelements_correct:
+      forall (m: t A) (i j : key) (v: A),
+      find i m = Some v -> List.In (append j i, v) (xelements m j).
+    Proof.
+      induction m; intros.
+       rewrite (gleaf i) in H; discriminate. 
+       destruct o; destruct i; simpl; simpl in H.
+        rewrite append_assoc_1; apply in_or_app; right; apply in_cons;
+          apply IHm2; auto.
+        rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
+        rewrite append_neutral_r; apply in_or_app; injection H as ->;
+          right; apply in_eq.
+        rewrite append_assoc_1; apply in_or_app; right; apply IHm2; auto.
+        rewrite append_assoc_0; apply in_or_app; left; apply IHm1; auto.
+        congruence.
+    Qed.
+
+  Theorem elements_correct:
+    forall (m: t A) (i: key) (v: A),
+    find i m = Some v -> List.In (i, v) (elements m).
+  Proof.
+    intros m i v H.
+    exact (xelements_correct m i xH H).
+  Qed.
+
+  Fixpoint xfind (i j : key) (m : t A) : option A :=
+      match i, j with
+      | _, xH => find i m
+      | xO ii, xO jj => xfind ii jj m
+      | xI ii, xI jj => xfind ii jj m
+      | _, _ => None
+      end.
+
+   Lemma xfind_left :
+      forall (j i : key) (m1 m2 : t A) (o : option A) (v : A),
+      xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v.
+    Proof.
+      induction j; intros; destruct i; simpl; simpl in H; auto; try congruence.
+      destruct i; simpl in *; auto.
+    Qed.
+
+    Lemma xelements_ii :
+      forall (m: t A) (i j : key) (v: A),
+      List.In (xI i, v) (xelements m (xI j)) -> List.In (i, v) (xelements m j).
+    Proof.
+      induction m.
+       simpl; auto.
+       intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H);
+         apply in_or_app.
+        left; apply IHm1; auto.
+        right; destruct (in_inv H0).
+         injection H1 as -> ->; apply in_eq.
+         apply in_cons; apply IHm2; auto.
+        left; apply IHm1; auto.
+        right; apply IHm2; auto.
+    Qed.
+
+    Lemma xelements_io :
+      forall (m: t A) (i j : key) (v: A),
+      ~List.In (xI i, v) (xelements m (xO j)).
+    Proof.
+      induction m.
+       simpl; auto.
+       intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
+        apply (IHm1 _ _ _ H0).
+        destruct (in_inv H0).
+         congruence.
+         apply (IHm2 _ _ _ H1).
+        apply (IHm1 _ _ _ H0).
+        apply (IHm2 _ _ _ H0).
+    Qed.
+
+    Lemma xelements_oo :
+      forall (m: t A) (i j : key) (v: A),
+      List.In (xO i, v) (xelements m (xO j)) -> List.In (i, v) (xelements m j).
+    Proof.
+      induction m.
+       simpl; auto.
+       intros; destruct o; simpl; simpl in H; destruct (in_app_or _ _ _ H);
+         apply in_or_app.
+        left; apply IHm1; auto.
+        right; destruct (in_inv H0).
+         injection H1 as -> ->; apply in_eq.
+         apply in_cons; apply IHm2; auto.
+        left; apply IHm1; auto.
+        right; apply IHm2; auto.
+    Qed.
+
+    Lemma xelements_oi :
+      forall (m: t A) (i j : key) (v: A),
+      ~List.In (xO i, v) (xelements m (xI j)).
+    Proof.
+      induction m.
+       simpl; auto.
+       intros; destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
+        apply (IHm1 _ _ _ H0).
+        destruct (in_inv H0).
+         congruence.
+         apply (IHm2 _ _ _ H1).
+        apply (IHm1 _ _ _ H0).
+        apply (IHm2 _ _ _ H0).
+    Qed.
+
+    Lemma xelements_ih :
+      forall (m1 m2: t A) (o: option A) (i : key) (v: A),
+      List.In (xI i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m2 xH).
+    Proof.
+      destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
+        absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto.
+        destruct (in_inv H0).
+         congruence.
+         apply xelements_ii; auto.
+        absurd (List.In (xI i, v) (xelements m1 2)); auto; apply xelements_io; auto.
+        apply xelements_ii; auto.
+    Qed.
+
+    Lemma xelements_oh :
+      forall (m1 m2: t A) (o: option A) (i : key) (v: A),
+      List.In (xO i, v) (xelements (Node m1 o m2) xH) -> List.In (i, v) (xelements m1 xH).
+    Proof.
+      destruct o; simpl; intros; destruct (in_app_or _ _ _ H).
+        apply xelements_oo; auto.
+        destruct (in_inv H0).
+         congruence.
+         absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto.
+        apply xelements_oo; auto.
+        absurd (List.In (xO i, v) (xelements m2 3)); auto; apply xelements_oi; auto.
+    Qed.
+
+    Lemma xelements_hi :
+      forall (m: t A) (i : key) (v: A),
+      ~List.In (xH, v) (xelements m (xI i)).
+    Proof.
+      induction m; intros.
+       simpl; auto.
+       destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
+        generalize H0; apply IHm1; auto.
+        destruct (in_inv H0).
+         congruence.
+         generalize H1; apply IHm2; auto.
+        generalize H0; apply IHm1; auto.
+        generalize H0; apply IHm2; auto.
+    Qed.
+
+    Lemma xelements_ho :
+      forall (m: t A) (i : key) (v: A),
+      ~List.In (xH, v) (xelements m (xO i)).
+    Proof.
+      induction m; intros.
+       simpl; auto.
+       destruct o; simpl; intro H; destruct (in_app_or _ _ _ H).
+        generalize H0; apply IHm1; auto.
+        destruct (in_inv H0).
+         congruence.
+         generalize H1; apply IHm2; auto.
+        generalize H0; apply IHm1; auto.
+        generalize H0; apply IHm2; auto.
+    Qed.
+
+    Lemma find_xfind_h :
+      forall (m: t A) (i: key), find i m = xfind i xH m.
+    Proof.
+      destruct i; simpl; auto.
+    Qed.
+
+    Lemma xelements_complete:
+      forall (i j : key) (m: t A) (v: A),
+      List.In (i, v) (xelements m j) -> xfind i j m = Some v.
+    Proof.
+      induction i; simpl; intros; destruct j; simpl.
+       apply IHi; apply xelements_ii; auto.
+       absurd (List.In (xI i, v) (xelements m (xO j))); auto; apply xelements_io.
+       destruct m.
+        simpl in H; tauto.
+        rewrite find_xfind_h. apply IHi. apply (xelements_ih _ _ _ _ _ H).
+       absurd (List.In (xO i, v) (xelements m (xI j))); auto; apply xelements_oi.
+       apply IHi; apply xelements_oo; auto.
+       destruct m.
+        simpl in H; tauto.
+        rewrite find_xfind_h. apply IHi. apply (xelements_oh _ _ _ _ _ H).
+       absurd (List.In (xH, v) (xelements m (xI j))); auto; apply xelements_hi.
+       absurd (List.In (xH, v) (xelements m (xO j))); auto; apply xelements_ho.
+       destruct m.
+        simpl in H; tauto.
+        destruct o; simpl in H; destruct (in_app_or _ _ _ H).
+         absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho.
+         destruct (in_inv H0).
+          congruence.
+          absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi.
+         absurd (List.In (xH, v) (xelements m1 (xO xH))); auto; apply xelements_ho.
+         absurd (List.In (xH, v) (xelements m2 (xI xH))); auto; apply xelements_hi.
+    Qed.
+
+  Theorem elements_complete:
+    forall (m: t A) (i: key) (v: A),
+    List.In (i, v) (elements m) -> find i m = Some v.
+  Proof.
+    intros m i v H.
+    unfold elements in H.
+    rewrite find_xfind_h.
+    exact (xelements_complete i xH m v H).
+  Qed.
+
+  Lemma cardinal_1 :
+   forall (m: t A), cardinal m = length (elements m).
+  Proof.
+   unfold elements.
+   intros m; set (p:=1); clearbody p; revert m p.
+   induction m; simpl; auto; intros.
+   rewrite (IHm1 (append p 2)), (IHm2 (append p 3)); auto.
+   destruct o; rewrite app_length; simpl; omega.
+  Qed.
+
+  End CompcertSpec.
+
+  Definition MapsTo (i:key)(v:A)(m:t A) := find i m = Some v.
+
+  Definition In (i:key)(m:t A) := exists e:A, MapsTo i e m.
+
+  Definition Empty m := forall (a : key)(e:A) , ~ MapsTo a e m.
+
+  Definition eq_key (p p':key*A) := E.eq (fst p) (fst p').
+
+  Definition eq_key_elt (p p':key*A) :=
+          E.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+  Definition lt_key (p p':key*A) := E.lt (fst p) (fst p').
+
+  Global Instance eqk_equiv : Equivalence eq_key := _.
+  Global Instance eqke_equiv : Equivalence eq_key_elt := _.
+  Global Instance ltk_strorder : StrictOrder lt_key := _.
+
+  Lemma mem_find :
+    forall m x, mem x m = match find x m with None => false | _ => true end.
+  Proof.
+  induction m; destruct x; simpl; auto.
+  Qed.
+
+  Lemma Empty_alt : forall m, Empty m <-> forall a, find a m = None.
+  Proof.
+  unfold Empty, MapsTo.
+  intuition.
+  generalize (H a).
+  destruct (find a m); intuition.
+  elim (H0 a0); auto.
+  rewrite H in H0; discriminate.
+  Qed.
+
+  Lemma Empty_Node : forall l o r, Empty (Node l o r) <-> o=None /\ Empty l /\ Empty r.
+  Proof.
+  intros l o r.
+  split.
+  rewrite Empty_alt.
+  split.
+  destruct o; auto.
+  generalize (H 1); simpl; auto.
+  split; rewrite Empty_alt; intros.
+  generalize (H (xO a)); auto.
+  generalize (H (xI a)); auto.
+  intros (H,(H0,H1)).
+  subst.
+  rewrite Empty_alt; intros.
+  destruct a; auto.
+  simpl; generalize H1; rewrite Empty_alt; auto.
+  simpl; generalize H0; rewrite Empty_alt; auto.
+  Qed.
+
+  Section FMapSpec.
+
+  Lemma mem_1 : forall m x, In x m -> mem x m = true.
+  Proof.
+  unfold In, MapsTo; intros m x; rewrite mem_find.
+  destruct 1 as (e0,H0); rewrite H0; auto.
+  Qed.
+
+  Lemma mem_2 : forall m x, mem x m = true -> In x m.
+  Proof.
+  unfold In, MapsTo; intros m x; rewrite mem_find.
+  destruct (find x m).
+  exists a; auto.
+  intros; discriminate.
+  Qed.
+
+  Variable  m m' m'' : t A.
+  Variable x y z : key.
+  Variable e e' : A.
+
+  Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
+  Proof. intros; rewrite <- H; auto. Qed.
+
+  Lemma find_1 : MapsTo x e m -> find x m = Some e.
+  Proof. unfold MapsTo; auto. Qed.
+
+  Lemma find_2 : find x m = Some e -> MapsTo x e m.
+  Proof. red; auto. Qed.
+
+  Lemma empty_1 : Empty empty.
+  Proof.
+  rewrite Empty_alt; apply gempty.
+  Qed.
+
+  Lemma is_empty_1 : Empty m -> is_empty m = true.
+  Proof.
+  induction m; simpl; auto.
+  rewrite Empty_Node.
+  intros (H,(H0,H1)).
+  subst; simpl.
+  rewrite IHt0_1; simpl; auto.
+  Qed.
+
+  Lemma is_empty_2 : is_empty m = true -> Empty m.
+  Proof.
+  induction m; simpl; auto.
+  rewrite Empty_alt.
+  intros _; exact gempty.
+  rewrite Empty_Node.
+  destruct o.
+  intros; discriminate.
+  intro H; destruct (andb_prop _ _ H); intuition.
+  Qed.
+
+  Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
+  Proof.
+  unfold MapsTo.
+  intro H; rewrite H; clear H.
+  apply gss.
+  Qed.
+
+  Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+  Proof.
+  unfold MapsTo.
+  intros; rewrite gso; auto.
+  Qed.
+
+  Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+  Proof.
+  unfold MapsTo.
+  intro H; rewrite gso; auto.
+  Qed.
+
+  Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
+  Proof.
+  intros; intro.
+  generalize (mem_1 H0).
+  rewrite mem_find.
+  red in H.
+  rewrite H.
+  rewrite grs.
+  intros; discriminate.
+  Qed.
+
+  Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+  Proof.
+  unfold MapsTo.
+  intro H; rewrite gro; auto.
+  Qed.
+
+  Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
+  Proof.
+  unfold MapsTo.
+  destruct (E.eq_dec x y).
+  subst.
+  rewrite grs; intros; discriminate.
+  rewrite gro; auto.
+  Qed.
+
+  Lemma elements_1 :
+     MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+  Proof.
+  unfold MapsTo.
+  rewrite InA_alt.
+  intro H.
+  exists (x,e).
+  split.
+  red; simpl; unfold E.eq; auto.
+  apply elements_correct; auto.
+  Qed.
+
+  Lemma elements_2 :
+     InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+  Proof.
+  unfold MapsTo.
+  rewrite InA_alt.
+  intros ((e0,a),(H,H0)).
+  red in H; simpl in H; unfold E.eq in H; destruct H; subst.
+  apply elements_complete; auto.
+  Qed.
+
+  Lemma xelements_bits_lt_1 : forall p p0 q m v,
+     List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p.
+  Proof using.
+  intros.
+  generalize (xelements_complete _ _ _ _ H); clear H; intros.
+  revert p0 H.
+  induction p; destruct p0; simpl; intros; eauto; try discriminate.
+  Qed.
+
+  Lemma xelements_bits_lt_2 : forall p p0 q m v,
+     List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0.
+  Proof using.
+  intros.
+  generalize (xelements_complete _ _ _ _ H); clear H; intros.
+  revert p0 H.
+  induction p; destruct p0; simpl; intros; eauto; try discriminate.
+  Qed.
+
+  Lemma xelements_sort : forall p, sort lt_key (xelements m p).
+  Proof.
+  induction m.
+  simpl; auto.
+  destruct o; simpl; intros.
+  (* Some *)
+  apply (SortA_app (eqA:=eq_key_elt)); auto with *.
+  constructor; auto.
+  apply In_InfA; intros.
+  destruct y0.
+  red; red; simpl.
+  eapply xelements_bits_lt_2; eauto.
+  intros x0 y0.
+  do 2 rewrite InA_alt.
+  intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
+  destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst.
+  destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
+  red; red; simpl.
+  destruct H0.
+  injection H0 as H0 _; subst.
+  eapply xelements_bits_lt_1; eauto.
+  apply E.bits_lt_trans with p.
+  eapply xelements_bits_lt_1; eauto.
+  eapply xelements_bits_lt_2; eauto.
+  (* None *)
+  apply (SortA_app (eqA:=eq_key_elt)); auto with *.
+  intros x0 y0.
+  do 2 rewrite InA_alt.
+  intros (y1,(Hy1,H)) (y2,(Hy2,H0)).
+  destruct y1; destruct x0; compute in Hy1; destruct Hy1; subst.
+  destruct y2; destruct y0; compute in Hy2; destruct Hy2; subst.
+  red; red; simpl.
+  apply E.bits_lt_trans with p.
+  eapply xelements_bits_lt_1; eauto.
+  eapply xelements_bits_lt_2; eauto.
+  Qed.
+
+  Lemma elements_3 : sort lt_key (elements m).
+  Proof.
+  unfold elements.
+  apply xelements_sort; auto.
+  Qed.
+
+  Lemma elements_3w : NoDupA eq_key (elements m).
+  Proof.
+    apply ME.Sort_NoDupA.
+    apply elements_3.
+  Qed.
+
+  End FMapSpec.
+
+  (** [map] and [mapi] *)
+
+  Variable B : Type.
+
+  Section Mapi.
+
+    Variable f : key -> A -> B.
+
+    Fixpoint xmapi (m : t A) (i : key) : t B :=
+       match m with
+        | Leaf => @Leaf B
+        | Node l o r => Node (xmapi l (append i (xO xH)))
+                             (option_map (f i) o)
+                             (xmapi r (append i (xI xH)))
+       end.
+
+    Definition mapi m := xmapi m xH.
+
+  End Mapi.
+
+  Definition map (f : A -> B) m := mapi (fun _ => f) m.
+
+  End A.
+
+  Lemma xgmapi:
+      forall (A B: Type) (f: key -> A -> B) (i j : key) (m: t A),
+      find i (xmapi f m j) = option_map (f (append j i)) (find i m).
+  Proof.
+  induction i; intros; destruct m; simpl; auto.
+  rewrite (append_assoc_1 j i); apply IHi.
+  rewrite (append_assoc_0 j i); apply IHi.
+  rewrite (append_neutral_r j); auto.
+  Qed.
+
+  Theorem gmapi:
+    forall (A B: Type) (f: key -> A -> B) (i: key) (m: t A),
+    find i (mapi f m) = option_map (f i) (find i m).
+  Proof.
+  intros.
+  unfold mapi.
+  replace (f i) with (f (append xH i)).
+  apply xgmapi.
+  rewrite append_neutral_l; auto.
+  Qed.
+
+  Lemma mapi_1 :
+    forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'),
+    MapsTo x e m ->
+    exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+  Proof.
+  intros.
+  exists x.
+  split; [red; auto|].
+  apply find_2.
+  generalize (find_1 H); clear H; intros.
+  rewrite gmapi.
+  rewrite H.
+  simpl; auto.
+  Qed.
+
+  Lemma mapi_2 :
+    forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'),
+    In x (mapi f m) -> In x m.
+  Proof.
+  intros.
+  apply mem_2.
+  rewrite mem_find.
+  destruct H as (v,H).
+  generalize (find_1 H); clear H; intros.
+  rewrite gmapi in H.
+  destruct (find x m); auto.
+  simpl in *; discriminate.
+  Qed.
+
+  Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
+    MapsTo x e m -> MapsTo x (f e) (map f m).
+  Proof.
+  intros; unfold map.
+  destruct (mapi_1 (fun _ => f) H); intuition.
+  Qed.
+
+  Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
+    In x (map f m) -> In x m.
+  Proof.
+  intros; unfold map in *; eapply mapi_2; eauto.
+  Qed.
+
+  Section map2.
+  Variable A B C : Type.
+  Variable f : option A -> option B -> option C.
+
+  Arguments Leaf {A}.
+
+  Fixpoint xmap2_l (m : t A) : t C :=
+      match m with
+      | Leaf => Leaf
+      | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r)
+      end.
+
+  Lemma xgmap2_l : forall (i : key) (m : t A),
+          f None None = None -> find i (xmap2_l m) = f (find i m) None.
+    Proof.
+      induction i; intros; destruct m; simpl; auto.
+    Qed.
+
+  Fixpoint xmap2_r (m : t B) : t C :=
+      match m with
+      | Leaf => Leaf
+      | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r)
+      end.
+
+  Lemma xgmap2_r : forall (i : key) (m : t B),
+          f None None = None -> find i (xmap2_r m) = f None (find i m).
+    Proof.
+      induction i; intros; destruct m; simpl; auto.
+    Qed.
+
+  Fixpoint _map2 (m1 : t A)(m2 : t B) : t C :=
+    match m1 with
+    | Leaf => xmap2_r m2
+    | Node l1 o1 r1 =>
+        match m2 with
+        | Leaf => xmap2_l m1
+        | Node l2 o2 r2 => Node (_map2 l1 l2) (f o1 o2) (_map2 r1 r2)
+        end
+    end.
+
+    Lemma gmap2: forall (i: key)(m1:t A)(m2: t B),
+      f None None = None ->
+      find i (_map2 m1 m2) = f (find i m1) (find i m2).
+    Proof.
+      induction i; intros; destruct m1; destruct m2; simpl; auto;
+      try apply xgmap2_r; try apply xgmap2_l; auto.
+    Qed.
+
+  End map2.
+
+  Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') :=
+   _map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end).
+
+  Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
+    (x:key)(f:option elt->option elt'->option elt''),
+    In x m \/ In x m' ->
+    find x (map2 f m m') = f (find x m) (find x m').
+  Proof.
+  intros.
+  unfold map2.
+  rewrite gmap2; auto.
+  generalize (@mem_1 _ m x) (@mem_1 _ m' x).
+  do 2 rewrite mem_find.
+  destruct (find x m); simpl; auto.
+  destruct (find x m'); simpl; auto.
+  intros.
+  destruct H; intuition; try discriminate.
+  Qed.
+
+  Lemma  map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
+    (x:key)(f:option elt->option elt'->option elt''),
+    In x (map2 f m m') -> In x m \/ In x m'.
+  Proof.
+  intros.
+  generalize (mem_1 H); clear H; intros.
+  rewrite mem_find in H.
+  unfold map2 in H.
+  rewrite gmap2 in H; auto.
+  generalize (@mem_2 _ m x) (@mem_2 _ m' x).
+  do 2 rewrite mem_find.
+  destruct (find x m); simpl in *; auto.
+  destruct (find x m'); simpl in *; auto.
+  Qed.
+
+
+  Section Fold.
+
+    Variables A B : Type.
+    Variable f : key -> A -> B -> B.
+
+    Fixpoint xfoldi (m : t A) (v : B) (i : key) :=
+      match m with
+        | Leaf _ => v
+        | Node l (Some x) r =>
+          xfoldi r (f i x (xfoldi l v (append i 2))) (append i 3)
+        | Node l None r =>
+          xfoldi r (xfoldi l v (append i 2)) (append i 3)
+      end.
+
+    Lemma xfoldi_1 :
+      forall m v i,
+      xfoldi m v i = fold_left (fun a p => f (fst p) (snd p) a) (xelements m i) v.
+    Proof.
+      set (F := fun a p => f (fst p) (snd p) a).
+      induction m; intros; simpl; auto.
+      destruct o.
+      rewrite fold_left_app; simpl.
+      rewrite <- IHm1.
+      rewrite <- IHm2.
+      unfold F; simpl; reflexivity.
+      rewrite fold_left_app; simpl.
+      rewrite <- IHm1.
+      rewrite <- IHm2.
+      reflexivity.
+    Qed.
+
+    Definition fold m i := xfoldi m i 1.
+
+  End Fold.
+
+  Lemma fold_1 :
+    forall (A:Type)(m:t A)(B:Type)(i : B) (f : key -> A -> B -> B),
+    fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+  Proof.
+    intros; unfold fold, elements.
+    rewrite xfoldi_1; reflexivity.
+  Qed.
+
+  Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) : bool :=
+    match m1, m2 with
+      | Leaf _, _ => is_empty m2
+      | _, Leaf _ => is_empty m1
+      | Node l1 o1 r1, Node l2 o2 r2 =>
+           (match o1, o2 with
+             | None, None => true
+             | Some v1, Some v2 => cmp v1 v2
+             | _, _ => false
+            end)
+           && equal cmp l1 l2 && equal cmp r1 r2
+     end.
+
+  Definition Equal (A:Type)(m m':t A) :=
+    forall y, find y m = find y m'.
+  Definition Equiv (A:Type)(eq_elt:A->A->Prop) m m' :=
+    (forall k, In k m <-> In k m') /\
+    (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+  Definition Equivb (A:Type)(cmp: A->A->bool) := Equiv (Cmp cmp).
+
+  Lemma equal_1 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
+    Equivb cmp m m' -> equal cmp m m' = true.
+  Proof.
+  induction m.
+  (* m = Leaf *)
+  destruct 1.
+  simpl.
+  apply is_empty_1.
+  red; red; intros.
+  assert (In a (Leaf A)).
+  rewrite H.
+  exists e; auto.
+  destruct H2; red in H2.
+  destruct a; simpl in *; discriminate.
+  (* m = Node *)
+  destruct m'.
+  (* m' = Leaf *)
+  destruct 1.
+  simpl.
+  destruct o.
+  assert (In xH (Leaf A)).
+  rewrite <- H.
+  exists a; red; auto.
+  destruct H1; red in H1; simpl in H1; discriminate.
+  apply andb_true_intro; split; apply is_empty_1; red; red; intros.
+  assert (In (xO a) (Leaf A)).
+  rewrite <- H.
+  exists e; auto.
+  destruct H2; red in H2; simpl in H2; discriminate.
+  assert (In (xI a) (Leaf A)).
+  rewrite <- H.
+  exists e; auto.
+  destruct H2; red in H2; simpl in H2; discriminate.
+  (* m' = Node *)
+  destruct 1.
+  assert (Equivb cmp m1 m'1).
+    split.
+    intros k; generalize (H (xO k)); unfold In, MapsTo; simpl; auto.
+    intros k e e'; generalize (H0 (xO k) e e'); unfold In, MapsTo; simpl; auto.
+  assert (Equivb cmp m2 m'2).
+    split.
+    intros k; generalize (H (xI k)); unfold In, MapsTo; simpl; auto.
+    intros k e e'; generalize (H0 (xI k) e e'); unfold In, MapsTo; simpl; auto.
+  simpl.
+  destruct o; destruct o0; simpl.
+  repeat (apply andb_true_intro; split); auto.
+  apply (H0 xH); red; auto.
+  generalize (H xH); unfold In, MapsTo; simpl; intuition.
+  destruct H4; try discriminate; eauto.
+  generalize (H xH); unfold In, MapsTo; simpl; intuition.
+  destruct H5; try discriminate; eauto.
+  apply andb_true_intro; split; auto.
+  Qed.
+
+  Lemma equal_2 : forall (A:Type)(m m':t A)(cmp:A->A->bool),
+    equal cmp m m' = true -> Equivb cmp m m'.
+  Proof.
+  induction m.
+  (* m = Leaf *)
+  simpl.
+  split; intros.
+  split.
+  destruct 1; red in H0; destruct k; discriminate.
+  destruct 1; elim (is_empty_2 H H0).
+  red in H0; destruct k; discriminate.
+  (* m = Node *)
+  destruct m'.
+  (* m' = Leaf *)
+  simpl.
+  destruct o; intros; try discriminate.
+  destruct (andb_prop _ _ H); clear H.
+  split; intros.
+  split; unfold In, MapsTo; destruct 1.
+  destruct k; simpl in *; try discriminate.
+  destruct (is_empty_2 H1 (find_2 _ _ H)).
+  destruct (is_empty_2 H0 (find_2 _ _ H)).
+  destruct k; simpl in *; discriminate.
+  unfold In, MapsTo; destruct k; simpl in *; discriminate.
+  (* m' = Node *)
+  destruct o; destruct o0; simpl; intros; try discriminate.
+  destruct (andb_prop _ _ H); clear H.
+  destruct (andb_prop _ _ H0); clear H0.
+  destruct (IHm1 _ _ H2); clear H2 IHm1.
+  destruct (IHm2 _ _ H1); clear H1 IHm2.
+  split; intros.
+  destruct k; unfold In, MapsTo in *; simpl; auto.
+  split; eauto.
+  destruct k; unfold In, MapsTo in *; simpl in *.
+  eapply H4; eauto.
+  eapply H3; eauto.
+  congruence.
+  destruct (andb_prop _ _ H); clear H.
+  destruct (IHm1 _ _ H0); clear H0 IHm1.
+  destruct (IHm2 _ _ H1); clear H1 IHm2.
+  split; intros.
+  destruct k; unfold In, MapsTo in *; simpl; auto.
+  split; eauto.
+  destruct k; unfold In, MapsTo in *; simpl in *.
+  eapply H3; eauto.
+  eapply H2; eauto.
+  try discriminate.
+  Qed.
+
+End PositiveMap.
+
+(** Here come some additional facts about this implementation.
+  Most are facts that cannot be derivable from the general interface. *)
+
+
+Module PositiveMapAdditionalFacts.
+  Import PositiveMap.
+
+  (* Derivable from the Map interface *)
+  Theorem gsspec:
+    forall (A:Type)(i j: key) (x: A) (m: t A),
+    find i (add j x m) = if E.eq_dec i j then Some x else find i m.
+  Proof.
+    intros.
+    destruct (E.eq_dec i j) as [ ->|]; [ apply gss | apply gso; auto ].
+  Qed.
+
+   (* Not derivable from the Map interface *)
+  Theorem gsident:
+    forall (A:Type)(i: key) (m: t A) (v: A),
+    find i m = Some v -> add i v m = m.
+  Proof.
+    induction i; intros; destruct m; simpl; simpl in H; try congruence.
+     rewrite (IHi m2 v H); congruence.
+     rewrite (IHi m1 v H); congruence.
+  Qed.
+
+  Lemma xmap2_lr :
+      forall (A B : Type)(f g: option A -> option A -> option B)(m : t A),
+      (forall (i j : option A), f i j = g j i) ->
+      xmap2_l f m = xmap2_r g m.
+    Proof.
+      induction m; intros; simpl; auto.
+      rewrite IHm1; auto.
+      rewrite IHm2; auto.
+      rewrite H; auto.
+    Qed.
+
+  Theorem map2_commut:
+    forall (A B: Type) (f g: option A -> option A -> option B),
+    (forall (i j: option A), f i j = g j i) ->
+    forall (m1 m2: t A),
+    _map2 f m1 m2 = _map2 g m2 m1.
+  Proof.
+    intros A B f g Eq1.
+    assert (Eq2: forall (i j: option A), g i j = f j i).
+      intros; auto.
+    induction m1; intros; destruct m2; simpl;
+      try rewrite Eq1;
+      repeat rewrite (xmap2_lr f g);
+      repeat rewrite (xmap2_lr g f);
+      auto.
+     rewrite IHm1_1.
+     rewrite IHm1_2.
+     auto.
+  Qed.
+
+End PositiveMapAdditionalFacts.
diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v
new file mode 100644
index 0000000000..12550ddf9a
--- /dev/null
+++ b/theories/FSets/FMapWeakList.v
@@ -0,0 +1,999 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * Finite map library *)
+
+(** This file proposes an implementation of the non-dependent interface
+ [FMapInterface.WS] using lists of pairs, unordered but without redundancy. *)
+
+Require Import FunInd FMapInterface.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Module Raw (X:DecidableType).
+
+Module Import PX := KeyDecidableType X.
+
+Definition key := X.t.
+Definition t (elt:Type) := list (X.t * elt).
+
+Section Elt.
+
+Variable elt : Type.
+
+Notation eqk := (eqk (elt:=elt)).
+Notation eqke := (eqke (elt:=elt)).
+Notation MapsTo := (MapsTo (elt:=elt)).
+Notation In := (In (elt:=elt)).
+Notation NoDupA := (NoDupA eqk).
+
+(** * [empty] *)
+
+Definition empty : t elt := nil.
+
+Definition Empty m := forall (a : key)(e:elt), ~ MapsTo a e m.
+
+Lemma empty_1 : Empty empty.
+Proof.
+ unfold Empty,empty.
+ intros a e.
+ intro abs.
+ inversion abs.
+Qed.
+
+Hint Resolve empty_1 : core.
+
+Lemma empty_NoDup : NoDupA empty.
+Proof.
+ unfold empty; auto.
+Qed.
+
+(** * [is_empty] *)
+
+Definition is_empty (l : t elt) : bool := if l then true else false.
+
+Lemma is_empty_1 :forall m, Empty m -> is_empty m = true.
+Proof.
+ unfold Empty, PX.MapsTo.
+ intros m.
+ case m;auto.
+ intros p l inlist.
+ destruct p.
+ absurd (InA eqke (t0, e) ((t0, e) :: l));auto.
+Qed.
+
+Lemma is_empty_2 : forall m, is_empty m = true -> Empty m.
+Proof.
+ intros m.
+ case m;auto.
+ intros p l abs.
+ inversion abs.
+Qed.
+
+(** * [mem] *)
+
+Function mem (k : key) (s : t elt) {struct s} : bool :=
+  match s with
+   | nil => false
+   | (k',_) :: l => if X.eq_dec k k' then true else mem k l
+  end.
+
+Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true.
+Proof.
+ intros m Hm x; generalize Hm; clear Hm.
+ functional induction (mem x m);intros NoDup belong1;trivial.
+ inversion belong1. inversion H.
+ inversion_clear NoDup.
+ inversion_clear belong1.
+ inversion_clear H1.
+ compute in H2; destruct H2.
+ contradiction.
+ apply IHb; auto.
+ exists x0; auto.
+Qed.
+
+Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m.
+Proof.
+ intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo.
+ functional induction (mem x m); intros NoDup hyp; try discriminate.
+ exists _x; auto.
+ inversion_clear NoDup.
+ destruct IHb; auto.
+ exists x0; auto.
+Qed.
+
+(** * [find] *)
+
+Function find (k:key) (s: t elt) {struct s} : option elt :=
+  match s with
+   | nil => None
+   | (k',x)::s' => if X.eq_dec k k' then Some x else find k s'
+  end.
+
+Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+Proof.
+ intros m x. unfold PX.MapsTo.
+ functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto.
+Qed.
+
+Lemma find_1 : forall m (Hm:NoDupA m) x e,
+  MapsTo x e m -> find x m = Some e.
+Proof.
+ intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (find x m);simpl; subst; try clear H_eq_1.
+
+ inversion 2.
+
+ do 2 inversion_clear 1.
+ compute in H2; destruct H2; subst; trivial.
+ elim H; apply InA_eqk with (x,e); auto.
+
+ do 2 inversion_clear 1; auto.
+ compute in H2; destruct H2; elim _x; auto.
+Qed.
+
+(* Not part of the exported specifications, used later for [combine]. *)
+
+Lemma find_eq : forall m (Hm:NoDupA m) x x',
+   X.eq x x' -> find x m = find x' m.
+Proof.
+ induction m; simpl; auto; destruct a; intros.
+ inversion_clear Hm.
+ rewrite (IHm H1 x x'); auto.
+ destruct (X.eq_dec x t0) as [|Hneq]; destruct (X.eq_dec x' t0) as [|?Hneq'];
+   trivial.
+ elim Hneq'; apply X.eq_trans with x; auto.
+ elim Hneq; apply X.eq_trans with x'; auto.
+Qed.
+
+(** * [add] *)
+
+Function add (k : key) (x : elt) (s : t elt) {struct s} : t elt :=
+  match s with
+   | nil => (k,x) :: nil
+   | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l
+  end.
+
+Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m).
+Proof.
+ intros m x y e; generalize y; clear y; unfold PX.MapsTo.
+ functional induction (add x e m);simpl;auto.
+Qed.
+
+Lemma add_2 : forall m x y e e',
+  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+Proof.
+ intros m x  y e e'; generalize y e; clear y e; unfold PX.MapsTo.
+ functional induction (add x e' m);simpl;auto.
+ intros y' e'' eqky';  inversion_clear 1.
+ destruct H0; simpl in *.
+ elim eqky'; apply X.eq_trans with k'; auto.
+ auto.
+ intros y' e'' eqky'; inversion_clear 1; intuition.
+Qed.
+
+Lemma add_3 : forall m x y e e',
+  ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+Proof.
+ intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo.
+ functional induction (add x e' m);simpl;auto.
+ intros; apply (In_inv_3 H0); auto.
+ constructor 2; apply (In_inv_3 H0); auto.
+ inversion_clear 2; auto.
+Qed.
+
+Lemma add_3' : forall m x y e e',
+  ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m.
+Proof.
+ intros m x y e e'. generalize y e; clear y e.
+ functional induction (add x e' m);simpl;auto.
+ inversion_clear 2.
+ compute in H1; elim H; auto.
+ inversion H1.
+ constructor 2; inversion_clear H0; auto.
+ compute in H1; elim H; auto.
+ inversion_clear 2; auto.
+Qed.
+
+Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m).
+Proof.
+ induction m.
+ simpl; constructor; auto; red; inversion 1.
+ intros.
+ destruct a as (x',e').
+ simpl; case (X.eq_dec x x'); inversion_clear Hm; auto.
+ constructor; auto.
+ contradict H.
+ apply InA_eqk with (x,e); auto.
+ constructor; auto.
+ contradict H; apply add_3' with x e; auto.
+Qed.
+
+(* Not part of the exported specifications, used later for [combine]. *)
+
+Lemma add_eq : forall m (Hm:NoDupA m) x a e,
+   X.eq x a -> find x (add a e m) = Some e.
+Proof.
+ intros.
+ apply find_1; auto.
+ apply add_NoDup; auto.
+ apply add_1; auto.
+Qed.
+
+Lemma add_not_eq : forall m (Hm:NoDupA m) x a e,
+  ~X.eq x a -> find x (add a e m) = find x m.
+Proof.
+ intros.
+ case_eq (find x m); intros.
+ apply find_1; auto.
+ apply add_NoDup; auto.
+ apply add_2; auto.
+ apply find_2; auto.
+ case_eq (find x (add a e m)); intros; auto.
+ rewrite <- H0; symmetry.
+ apply find_1; auto.
+ apply add_3 with a e; auto.
+ apply find_2; auto.
+Qed.
+
+
+(** * [remove] *)
+
+Function remove (k : key) (s : t elt) {struct s} : t elt :=
+  match s with
+   | nil => nil
+   | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l
+  end.
+
+Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m).
+Proof.
+ intros m Hm x y; generalize Hm; clear Hm.
+ functional induction (remove x m);simpl;intros;auto.
+
+ red; inversion 1; inversion H1.
+
+ inversion_clear Hm.
+ subst.
+ contradict H0.
+ destruct H0 as (e,H2); unfold PX.MapsTo in H2.
+ apply InA_eqk with (y,e); auto.
+ compute; apply X.eq_trans with x; auto.
+
+ intro H2.
+ destruct H2 as (e,H2); inversion_clear H2.
+ compute in H0; destruct H0.
+ elim _x; apply X.eq_trans with y; auto.
+ inversion_clear Hm.
+ elim (IHt0 H2 H).
+ exists e; auto.
+Qed.
+
+Lemma remove_2 : forall m (Hm:NoDupA m) x y e,
+  ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (remove x m);auto.
+ inversion_clear 3; auto.
+ compute in H1; destruct H1.
+ elim H; apply X.eq_trans with k'; auto.
+
+ inversion_clear 1; inversion_clear 2; auto.
+Qed.
+
+Lemma remove_3 : forall m (Hm:NoDupA m) x y e,
+  MapsTo y e (remove x m) -> MapsTo y e m.
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (remove x m);auto.
+ do 2 inversion_clear 1; auto.
+Qed.
+
+Lemma remove_3' : forall m (Hm:NoDupA m) x y e,
+  InA eqk (y,e) (remove x m) -> InA eqk (y,e) m.
+Proof.
+ intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo.
+ functional induction (remove x m);auto.
+ do 2 inversion_clear 1; auto.
+Qed.
+
+Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ inversion_clear Hm.
+ destruct a as (x',e').
+ simpl; case (X.eq_dec x x'); auto.
+ constructor; auto.
+ contradict H; apply remove_3' with x; auto.
+Qed.
+
+(** * [elements] *)
+
+Definition elements (m: t elt) := m.
+
+Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m).
+Proof.
+ auto.
+Qed.
+
+Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m.
+Proof.
+auto.
+Qed.
+
+Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m).
+Proof.
+ auto.
+Qed.
+
+(** * [fold] *)
+
+Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} :  A :=
+  match m with
+   | nil => acc
+   | (k,e)::m' => fold f m' (f k e acc)
+  end.
+
+Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A),
+  fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+Proof.
+ intros; functional induction (@fold A f m i); auto.
+Qed.
+
+(** * [equal] *)
+
+Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) :=
+  match find k m' with
+   | None => false
+   | Some e' => cmp e e'
+  end.
+
+Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool :=
+  fold (fun k e b => andb (check cmp k e m') b) m true.
+
+Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool :=
+  andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m).
+
+Definition Submap cmp m m' :=
+  (forall k, In k m -> In k m') /\
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
+
+Definition Equivb cmp m m' :=
+  (forall k, In k m <-> In k m') /\
+  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
+
+Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp,
+  Submap cmp m m' -> submap cmp m m' = true.
+Proof.
+ unfold Submap, submap.
+ induction m.
+ simpl; auto.
+ destruct a; simpl; intros.
+ destruct H.
+ inversion_clear Hm.
+ assert (H3 : In t0 m').
+  apply H; exists e; auto.
+ destruct H3 as (e', H3).
+ unfold check at 2; rewrite (find_1 Hm' H3).
+ rewrite (H0 t0); simpl; auto.
+ eapply IHm; auto.
+ split; intuition.
+ apply H.
+ destruct H5 as (e'',H5); exists e''; auto.
+ apply H0 with k; auto.
+Qed.
+
+Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp,
+  submap cmp m m' = true -> Submap cmp m m'.
+Proof.
+ unfold Submap, submap.
+ induction m.
+ simpl; auto.
+ intuition.
+ destruct H0; inversion H0.
+ inversion H0.
+
+ destruct a; simpl; intros.
+ inversion_clear Hm.
+ rewrite andb_b_true in H.
+ assert (check cmp t0 e m' = true).
+  clear H1 H0 Hm' IHm.
+  set (b:=check cmp t0 e m') in *.
+  generalize H; clear H; generalize b; clear b.
+  induction m; simpl; auto; intros.
+  destruct a; simpl in *.
+  destruct (andb_prop _ _ (IHm _ H)); auto.
+ rewrite H2 in H.
+ destruct (IHm H1 m' Hm' cmp H); auto.
+ unfold check in H2.
+ case_eq (find t0 m'); [intros e' H5 | intros H5];
+  rewrite H5 in H2; try discriminate.
+ split; intros.
+ destruct H6 as (e0,H6); inversion_clear H6.
+ compute in H7; destruct H7; subst.
+ exists e'.
+ apply PX.MapsTo_eq with t0; auto.
+ apply find_2; auto.
+ apply H3.
+ exists e0; auto.
+ inversion_clear H6.
+ compute in H8; destruct H8; subst.
+ rewrite (find_1 Hm' (PX.MapsTo_eq H6 H7)) in H5; congruence.
+ apply H4 with k; auto.
+Qed.
+
+(** Specification of [equal] *)
+
+Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp,
+  Equivb cmp m m' -> equal cmp m m' = true.
+Proof.
+ unfold Equivb, equal.
+ intuition.
+ apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder.
+Qed.
+
+Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp,
+  equal cmp m m' = true -> Equivb cmp m m'.
+Proof.
+ unfold Equivb, equal.
+ intros.
+ destruct (andb_prop _ _ H); clear H.
+ generalize (submap_2 Hm Hm' H0).
+ generalize (submap_2 Hm' Hm H1).
+ firstorder.
+Qed.
+
+Variable elt':Type.
+
+(** * [map] and [mapi] *)
+
+Fixpoint map (f:elt -> elt') (m:t elt) : t elt' :=
+  match m with
+   | nil => nil
+   | (k,e)::m' => (k,f e) :: map f m'
+  end.
+
+Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' :=
+  match m with
+   | nil => nil
+   | (k,e)::m' => (k,f k e) :: mapi f m'
+  end.
+
+End Elt.
+Section Elt2.
+(* A new section is necessary for previous definitions to work
+   with different [elt], especially [MapsTo]... *)
+
+Variable elt elt' : Type.
+
+(** Specification of [map] *)
+
+Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'),
+  MapsTo x e m -> MapsTo x (f e) (map f m).
+Proof.
+ intros m x e f.
+ (* functional induction map elt elt' f m.  *) (* Marche pas ??? *)
+ induction m.
+ inversion 1.
+
+ destruct a as (x',e').
+ simpl.
+ inversion_clear 1.
+ constructor 1.
+ unfold eqke in *; simpl in *; intuition congruence.
+ constructor 2.
+ unfold MapsTo in *; auto.
+Qed.
+
+Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'),
+  In x (map f m) -> In x m.
+Proof.
+ intros m x f.
+ (* functional induction map elt elt' f m. *) (* Marche pas ??? *)
+ induction m; simpl.
+ intros (e,abs).
+ inversion abs.
+
+ destruct a as (x',e).
+ intros hyp.
+ inversion hyp. clear hyp.
+ inversion H; subst; rename x0 into e'.
+ exists e; constructor.
+ unfold eqke in *; simpl in *; intuition.
+ destruct IHm as (e'',hyp).
+ exists e'; auto.
+ exists e''.
+ constructor 2; auto.
+Qed.
+
+Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'),
+  NoDupA (@eqk elt') (map f m).
+Proof.
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm.
+ constructor; auto.
+ contradict H.
+ (* il faut un map_1 avec eqk au lieu de eqke *)
+ clear IHm H0.
+ induction m; simpl in *; auto.
+ inversion H.
+ destruct a; inversion H; auto.
+Qed.
+
+(** Specification of [mapi] *)
+
+Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'),
+  MapsTo x e m ->
+  exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m).
+Proof.
+ intros m x e f.
+ (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
+ induction m.
+ inversion 1.
+
+ destruct a as (x',e').
+ simpl.
+ inversion_clear 1.
+ exists x'.
+ destruct H0; simpl in *.
+ split; auto.
+ constructor 1.
+ unfold eqke in *; simpl in *; intuition congruence.
+ destruct IHm as (y, hyp); auto.
+ exists y; intuition.
+Qed.
+
+Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'),
+  In x (mapi f m) -> In x m.
+Proof.
+ intros m x f.
+ (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *)
+ induction m; simpl.
+ intros (e,abs).
+ inversion abs.
+
+ destruct a as (x',e).
+ intros hyp.
+ inversion hyp. clear hyp.
+ inversion H; subst; rename x0 into e'.
+ exists e; constructor.
+ unfold eqke in *; simpl in *; intuition.
+ destruct IHm as (e'',hyp).
+ exists e'; auto.
+ exists e''.
+ constructor 2; auto.
+Qed.
+
+Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'),
+  NoDupA (@eqk elt') (mapi f m).
+Proof.
+ induction m; simpl; auto.
+ intros.
+ destruct a as (x',e').
+ inversion_clear Hm; auto.
+ constructor; auto.
+ contradict H.
+ clear IHm H0.
+ induction m; simpl in *; auto.
+ inversion_clear H.
+ destruct a; inversion_clear H; auto.
+Qed.
+
+End Elt2.
+Section Elt3.
+
+Variable elt elt' elt'' : Type.
+
+Notation oee' := (option elt * option elt')%type.
+
+Definition combine_l (m:t elt)(m':t elt') : t oee' :=
+  mapi (fun k e => (Some e, find k m')) m.
+
+Definition combine_r (m:t elt)(m':t elt') : t oee' :=
+  mapi (fun k e' => (find k m, Some e')) m'.
+
+Definition fold_right_pair (A B C:Type)(f:A->B->C->C) :=
+  List.fold_right (fun p => f (fst p) (snd p)).
+
+Definition combine (m:t elt)(m':t elt') : t oee' :=
+  let l := combine_l m m' in
+  let r := combine_r m m' in
+  fold_right_pair (add (elt:=oee')) r l.
+
+Lemma fold_right_pair_NoDup :
+  forall l r (Hl: NoDupA (eqk (elt:=oee')) l)
+    (Hl: NoDupA (eqk (elt:=oee')) r),
+    NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) r l).
+Proof.
+ induction l; simpl; auto.
+ destruct a; simpl; auto.
+ inversion_clear 1.
+ intros; apply add_NoDup; auto.
+Qed.
+Hint Resolve fold_right_pair_NoDup : core.
+
+Lemma combine_NoDup :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'),
+  NoDupA (@eqk oee') (combine m m').
+Proof.
+ unfold combine, combine_r, combine_l.
+ intros.
+ set (f1 := fun (k : key) (e : elt) => (Some e, find k m')).
+ set (f2 := fun (k : key) (e' : elt') => (find k m, Some e')).
+ generalize (mapi_NoDup Hm f1).
+ generalize (mapi_NoDup Hm' f2).
+ set (l := mapi f1 m); clearbody l.
+ set (r := mapi f2 m'); clearbody r.
+ auto.
+Qed.
+
+Definition at_least_left (o:option elt)(o':option elt') :=
+  match o with
+   | None => None
+   | _  => Some (o,o')
+  end.
+
+Definition at_least_right (o:option elt)(o':option elt') :=
+  match o' with
+   | None => None
+   | _  => Some (o,o')
+  end.
+
+Lemma combine_l_1 :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
+  find x (combine_l m m') = at_least_left (find x m) (find x m').
+Proof.
+ unfold combine_l.
+ intros.
+ case_eq (find x m); intros.
+ simpl.
+ apply find_1.
+ apply mapi_NoDup; auto.
+ destruct (mapi_1 (fun k e => (Some e, find k m')) (find_2 H)) as (y,(H0,H1)).
+ rewrite (find_eq Hm' (X.eq_sym H0)); auto.
+ simpl.
+ case_eq (find x (mapi (fun k e => (Some e, find k m')) m)); intros; auto.
+ destruct (@mapi_2 _ _ m x (fun k e => (Some e, find k m'))).
+ exists p; apply find_2; auto.
+ rewrite (find_1 Hm H1) in H; discriminate.
+Qed.
+
+Lemma combine_r_1 :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
+  find x (combine_r m m') = at_least_right (find x m) (find x m').
+Proof.
+ unfold combine_r.
+ intros.
+ case_eq (find x m'); intros.
+ simpl.
+ apply find_1.
+ apply mapi_NoDup; auto.
+ destruct (mapi_1 (fun k e => (find k m, Some e)) (find_2 H)) as (y,(H0,H1)).
+ rewrite (find_eq Hm (X.eq_sym H0)); auto.
+ simpl.
+ case_eq (find x (mapi (fun k e' => (find k m, Some e')) m')); intros; auto.
+ destruct (@mapi_2 _ _ m' x (fun k e' => (find k m, Some e'))).
+ exists p; apply find_2; auto.
+ rewrite (find_1 Hm' H1) in H; discriminate.
+Qed.
+
+Definition at_least_one (o:option elt)(o':option elt') :=
+  match o, o' with
+   | None, None => None
+   | _, _  => Some (o,o')
+  end.
+
+Lemma combine_1 :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
+  find x (combine m m') = at_least_one (find x m) (find x m').
+Proof.
+ unfold combine.
+ intros.
+ generalize (combine_r_1 Hm Hm' x).
+ generalize (combine_l_1 Hm Hm' x).
+ assert (NoDupA (eqk (elt:=oee')) (combine_l m m')).
+  unfold combine_l; apply mapi_NoDup; auto.
+ assert (NoDupA (eqk (elt:=oee')) (combine_r m m')).
+  unfold combine_r; apply mapi_NoDup; auto.
+ set (l := combine_l m m') in *; clearbody l.
+ set (r := combine_r m m') in *; clearbody r.
+ set (o := find x m); clearbody o.
+ set (o' := find x m'); clearbody o'.
+ clear Hm' Hm m m'.
+ induction l.
+ destruct o; destruct o'; simpl; intros; discriminate || auto.
+ destruct a; simpl in *; intros.
+ destruct (X.eq_dec x t0); simpl in *.
+ unfold at_least_left in H1.
+ destruct o; simpl in *; try discriminate.
+ inversion H1; subst.
+ apply add_eq; auto.
+ inversion_clear H; auto.
+ inversion_clear H.
+ rewrite <- IHl; auto.
+ apply add_not_eq; auto.
+Qed.
+
+Variable f : option elt -> option elt' -> option elt''.
+
+Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) :=
+  match o with
+   | Some e => (k,e)::l
+   | None => l
+  end.
+
+Definition map2 m m' :=
+  let m0 : t oee' := combine m m' in
+  let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in
+  fold_right_pair (option_cons (A:=elt'')) nil m1.
+
+Lemma map2_NoDup :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'),
+  NoDupA (@eqk elt'') (map2 m m').
+Proof.
+ intros.
+ unfold map2.
+ assert (H0:=combine_NoDup Hm Hm').
+ set (l0:=combine m m') in *; clearbody l0.
+ set (f':= fun p : oee' => f (fst p) (snd p)).
+ assert (H1:=map_NoDup (elt' := option elt'') H0 f').
+ set (l1:=map f' l0) in *; clearbody l1.
+ clear f' f H0 l0 Hm Hm' m m'.
+ induction l1.
+ simpl; auto.
+ inversion_clear H1.
+ destruct a; destruct o; simpl; auto.
+ constructor; auto.
+ contradict H.
+ clear IHl1.
+ induction l1.
+ inversion H.
+ inversion_clear H0.
+ destruct a; destruct o; simpl in *; auto.
+ inversion_clear H; auto.
+Qed.
+
+Definition at_least_one_then_f (o:option elt)(o':option elt') :=
+  match o, o' with
+   | None, None => None
+   | _, _  => f o o'
+  end.
+
+Lemma map2_0 :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
+  find x (map2 m m') = at_least_one_then_f (find x m) (find x m').
+Proof.
+ intros.
+ unfold map2.
+ assert (H:=combine_1 Hm Hm' x).
+ assert (H2:=combine_NoDup Hm Hm').
+ set (f':= fun p : oee' => f (fst p) (snd p)).
+ set (m0 := combine m m') in *; clearbody m0.
+ set (o:=find x m) in *; clearbody o.
+ set (o':=find x m') in *; clearbody o'.
+ clear Hm Hm' m m'.
+ generalize H; clear H.
+ match goal with |- ?m=?n -> ?p=?q =>
+   assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end.
+ induction m0; simpl in *; intuition.
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ destruct a as (k,(oo,oo')); simpl in *.
+ inversion_clear H2.
+ destruct (X.eq_dec x k) as [|Hneq]; simpl in *.
+ (* x = k *)
+ assert (at_least_one_then_f o o' = f oo oo').
+  destruct o; destruct o'; simpl in *; inversion_clear H; auto.
+ rewrite H2.
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ destruct (X.eq_dec x k) as [|Hneq]; try contradict Hneq; auto.
+ destruct (IHm0 H1) as (_,H4); apply H4; auto.
+ case_eq (find x m0); intros; auto.
+ elim H0.
+ apply InA_eqk with (x,p); auto.
+ apply InA_eqke_eqk.
+ exact (find_2 H3).
+ (* k < x *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ destruct (X.eq_dec x k); [ contradict Hneq; auto | auto].
+ destruct (IHm0 H1) as (H3,_); apply H3; auto.
+ destruct (IHm0 H1) as (H3,_); apply H3; auto.
+
+ (* None -> None *)
+ destruct a as (k,(oo,oo')).
+ simpl.
+ inversion_clear H2.
+ destruct (X.eq_dec x k) as [|Hneq].
+ (* x = k *)
+ discriminate.
+ (* k < x *)
+ unfold f'; simpl.
+ destruct (f oo oo'); simpl.
+ destruct (X.eq_dec x k); [ contradict Hneq; auto | auto].
+ destruct (IHm0 H1) as (_,H4); apply H4; auto.
+ destruct (IHm0 H1) as (_,H4); apply H4; auto.
+Qed.
+
+(** Specification of [map2] *)
+Lemma map2_1 :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
+  In x m \/ In x m' ->
+  find x (map2 m m') = f (find x m) (find x m').
+Proof.
+ intros.
+ rewrite map2_0; auto.
+ destruct H as [(e,H)|(e,H)].
+ rewrite (find_1 Hm H).
+ destruct (find x m'); simpl; auto.
+ rewrite (find_1 Hm' H).
+ destruct (find x m); simpl; auto.
+Qed.
+
+Lemma map2_2 :
+  forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key),
+  In x (map2 m m') -> In x m \/ In x m'.
+Proof.
+ intros.
+ destruct H as (e,H).
+ generalize (map2_0 Hm Hm' x).
+ rewrite (find_1 (map2_NoDup Hm Hm') H).
+ generalize (@find_2 _ m x).
+ generalize (@find_2 _ m' x).
+ destruct (find x m);
+   destruct (find x m'); simpl; intros.
+ left; exists e0; auto.
+ left; exists e0; auto.
+ right; exists e0; auto.
+ discriminate.
+Qed.
+
+End Elt3.
+End Raw.
+
+
+Module Make (X: DecidableType) <: WS with Module E:=X.
+ Module Raw := Raw X.
+
+ Module E := X.
+ Definition key := E.t.
+
+#[universes(template)]
+ Record slist (elt:Type) :=
+  {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}.
+ Definition t (elt:Type) := slist elt.
+
+Section Elt.
+ Variable elt elt' elt'':Type.
+
+ Implicit Types m : t elt.
+ Implicit Types x y : key.
+ Implicit Types e : elt.
+
+ Definition empty : t elt := Build_slist (Raw.empty_NoDup elt).
+ Definition is_empty m : bool := Raw.is_empty (this m).
+ Definition add x e m : t elt := Build_slist (Raw.add_NoDup (NoDup m) x e).
+ Definition find x m : option elt := Raw.find x (this m).
+ Definition remove x m : t elt := Build_slist (Raw.remove_NoDup (NoDup m) x).
+ Definition mem x m : bool := Raw.mem x (this m).
+ Definition map f m : t elt' := Build_slist (Raw.map_NoDup (NoDup m) f).
+ Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup (NoDup m) f).
+ Definition map2 f m (m':t elt') : t elt'' :=
+   Build_slist (Raw.map2_NoDup f (NoDup m) (NoDup m')).
+ Definition elements m : list (key*elt) := @Raw.elements elt (this m).
+ Definition cardinal m := length (this m).
+ Definition fold (A:Type)(f:key->elt->A->A) m (i:A) : A := @Raw.fold elt A f (this m) i.
+ Definition equal cmp m m' : bool := @Raw.equal elt cmp (this m) (this m').
+ Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e (this m).
+ Definition In x m : Prop := Raw.PX.In x (this m).
+ Definition Empty m : Prop := Raw.Empty (this m).
+
+ Definition Equal m m' := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+         (forall k, In k m <-> In k m') /\
+         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+ Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp (this m) (this m').
+
+ Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt.
+ Definition eq_key_elt : (key*elt) -> (key*elt) -> Prop:= @Raw.PX.eqke elt.
+
+ Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.PX.MapsTo_eq elt (this m)). Qed.
+
+ Lemma mem_1 : forall m x, In x m -> mem x m = true.
+ Proof. intros m; exact (@Raw.mem_1 elt (this m) (NoDup m)). Qed.
+ Lemma mem_2 : forall m x, mem x m = true -> In x m.
+ Proof. intros m; exact (@Raw.mem_2 elt (this m) (NoDup m)). Qed.
+
+ Lemma empty_1 : Empty empty.
+ Proof. exact (@Raw.empty_1 elt). Qed.
+
+ Lemma is_empty_1 : forall m, Empty m -> is_empty m = true.
+ Proof. intros m; exact (@Raw.is_empty_1 elt (this m)). Qed.
+ Lemma is_empty_2 :  forall m, is_empty m = true -> Empty m.
+ Proof. intros m; exact (@Raw.is_empty_2 elt (this m)). Qed.
+
+ Lemma add_1 : forall m x y e, E.eq x y -> MapsTo y e (add x e m).
+ Proof. intros m; exact (@Raw.add_1 elt (this m)). Qed.
+ Lemma add_2 : forall m x y e e', ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+ Proof. intros m; exact (@Raw.add_2 elt (this m)). Qed.
+ Lemma add_3 : forall m x y e e', ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.add_3 elt (this m)). Qed.
+
+ Lemma remove_1 : forall m x y, E.eq x y -> ~ In y (remove x m).
+ Proof. intros m; exact (@Raw.remove_1 elt (this m) (NoDup m)). Qed.
+ Lemma remove_2 : forall m x y e, ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+ Proof. intros m; exact (@Raw.remove_2 elt (this m) (NoDup m)). Qed.
+ Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m.
+ Proof. intros m; exact (@Raw.remove_3 elt (this m) (NoDup m)). Qed.
+
+ Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e.
+ Proof. intros m; exact (@Raw.find_1 elt (this m) (NoDup m)). Qed.
+ Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.find_2 elt (this m)). Qed.
+
+ Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
+ Proof. intros m; exact (@Raw.elements_1 elt (this m)). Qed.
+ Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
+ Proof. intros m; exact (@Raw.elements_2 elt (this m)). Qed.
+ Lemma elements_3w : forall m, NoDupA eq_key (elements m).
+ Proof. intros m; exact (@Raw.elements_3w elt (this m) (NoDup m)). Qed.
+
+ Lemma cardinal_1 : forall m, cardinal m = length (elements m).
+ Proof. intros; reflexivity. Qed.
+
+ Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A),
+        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
+ Proof. intros m; exact (@Raw.fold_1 elt (this m)). Qed.
+
+ Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true.
+ Proof. intros m m'; exact (@Raw.equal_1 elt (this m) (NoDup m) (this m') (NoDup m')). Qed.
+ Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'.
+ Proof. intros m m'; exact (@Raw.equal_2 elt (this m) (NoDup m) (this m') (NoDup m')). Qed.
+
+ End Elt.
+
+ Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
+        MapsTo x e m -> MapsTo x (f e) (map f m).
+ Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' (this m)). Qed.
+ Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
+        In x (map f m) -> In x m.
+ Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' (this m)). Qed.
+
+ Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
+        (f:key->elt->elt'), MapsTo x e m ->
+        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
+ Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' (this m)). Qed.
+ Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
+        (f:key->elt->elt'), In x (mapi f m) -> In x m.
+ Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' (this m)). Qed.
+
+ Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''),
+	In x m \/ In x m' ->
+        find x (map2 f m m') = f (find x m) (find x m').
+ Proof.
+ intros elt elt' elt'' m m' x f;
+ exact (@Raw.map2_1 elt elt' elt'' f (this m) (NoDup m) (this m') (NoDup m') x).
+ Qed.
+ Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
+	(x:key)(f:option elt->option elt'->option elt''),
+        In x (map2 f m m') -> In x m \/ In x m'.
+ Proof.
+ intros elt elt' elt'' m m' x f;
+ exact (@Raw.map2_2 elt elt' elt'' f (this m) (NoDup m) (this m') (NoDup m') x).
+ Qed.
+
+End Make.
+
diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v
new file mode 100644
index 0000000000..ec50763589
--- /dev/null
+++ b/theories/FSets/FMaps.v
@@ -0,0 +1,18 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+
+Require Export OrderedType OrderedTypeEx OrderedTypeAlt.
+Require Export DecidableType DecidableTypeEx.
+Require Export FMapInterface.
+Require Export FMapPositive.
+Require Export FMapFacts.
+Require Export FMapWeakList.
+Require Export FMapList.
diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v
new file mode 100644
index 0000000000..dcaea894eb
--- /dev/null
+++ b/theories/FSets/FSetAVL.v
@@ -0,0 +1,56 @@
+(* -*- coding: utf-8 -*- *)
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * FSetAVL : Implementation of FSetInterface 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: heights of subtrees shouldn't differ by more
+    than 2), and hence has low complexities (e.g. add is logarithmic
+    in the size of the set). But proving these balancing preservations
+    is in fact not necessary for ensuring correct operational behavior
+    and hence fulfilling the FSet interface. As a consequence,
+    balancing results are not part of this file anymore, they can
+    now be found in [FSetFullAVL].
+
+    Four operations ([union], [subset], [compare] and [equal]) have
+    been slightly adapted in order to have only structural recursive
+    calls. The precise ocaml versions of these operations have also
+    been formalized (thanks to Function+measure), see [ocaml_union],
+    [ocaml_subset], [ocaml_compare] and [ocaml_equal] in
+    [FSetFullAVL]. The structural variants compute faster in Coq,
+    whereas the other variants produce nicer and/or (slightly) faster
+    code after extraction.
+*)
+
+Require Import FSetInterface ZArith Int.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** This is just a compatibility layer, the real implementation
+    is now in [MSetAVL] *)
+
+Require FSetCompat MSetAVL Orders OrdersAlt.
+
+Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X.
+ Module X' := OrdersAlt.Update_OT X.
+ Module MSet := MSetAVL.IntMake I X'.
+ Include FSetCompat.Backport_Sets X MSet.
+End IntMake.
+
+(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *)
+
+Module Make (X: OrderedType) <: S with Module E := X
+ :=IntMake(Z_as_Int)(X).
+
diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v
new file mode 100644
index 0000000000..3952c28061
--- /dev/null
+++ b/theories/FSets/FSetBridge.v
@@ -0,0 +1,815 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * Finite sets library *)
+
+(** This module implements bridges (as functors) from dependent
+    to/from non-dependent set signature. *)
+
+Require Export FSetInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+Set Firstorder Depth 2.
+
+(** * From non-dependent signature [S] to dependent signature [Sdep]. *)
+
+Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E.
+
+  Definition empty : {s : t | Empty s}.
+  Proof.
+    exists empty; auto with set.
+  Qed.
+
+  Definition is_empty : forall s : t, {Empty s} + {~ Empty s}.
+  Proof.
+    intros; generalize (is_empty_1 (s:=s)) (is_empty_2 (s:=s)).
+    case (is_empty s); intuition.
+  Qed.
+
+
+  Definition mem : forall (x : elt) (s : t), {In x s} + {~ In x s}.
+  Proof.
+    intros; generalize (mem_1 (s:=s) (x:=x)) (mem_2 (s:=s) (x:=x)).
+    case (mem x s); intuition.
+  Qed.
+
+  Definition Add (x : elt) (s s' : t) :=
+    forall y : elt, In y s' <-> E.eq x y \/ In y s.
+
+  Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}.
+  Proof.
+    intros; exists (add x s); auto.
+    unfold Add; intuition.
+    elim (E.eq_dec x y); auto.
+    intros; right.
+    eapply add_3; eauto.
+  Qed.
+
+  Definition singleton :
+    forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}.
+  Proof.
+    intros; exists (singleton x); intuition.
+  Qed.
+
+  Definition remove :
+    forall (x : elt) (s : t),
+    {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}.
+  Proof.
+    intros; exists (remove x s); intuition.
+    absurd (In x (remove x s)); auto with set.
+    apply In_1 with y; auto.
+    elim (E.eq_dec x y); intros; auto.
+    absurd (In x (remove x s)); auto with set.
+    apply In_1 with y; auto.
+    eauto with set.
+  Qed.
+
+  Definition union :
+    forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}.
+  Proof.
+    intros; exists (union s s'); intuition.
+  Qed.
+
+  Definition inter :
+    forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}.
+  Proof.
+    intros; exists (inter s s'); intuition; eauto with set.
+  Qed.
+
+  Definition diff :
+    forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}.
+  Proof.
+    intros; exists (diff s s'); intuition; eauto with set.
+    absurd (In x s'); eauto with set.
+  Qed.
+
+  Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}.
+  Proof.
+    intros.
+    generalize (equal_1 (s:=s) (s':=s')) (equal_2 (s:=s) (s':=s')).
+    case (equal s s'); intuition.
+  Qed.
+
+  Definition subset : forall s s' : t, {Subset s s'} + {~Subset s s'}.
+  Proof.
+    intros.
+    generalize (subset_1 (s:=s) (s':=s')) (subset_2 (s:=s) (s':=s')).
+    case (subset s s'); intuition.
+  Qed.
+
+  Definition elements :
+    forall s : t,
+    {l : list elt | sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}.
+   Proof.
+     intros; exists (elements s); intuition.
+   Defined.
+
+  Definition fold :
+    forall (A : Type) (f : elt -> A -> A) (s : t) (i : A),
+    {r : A |   let (l,_) := elements s in
+                  r = fold_left (fun a e => f e a) l i}.
+  Proof.
+  intros; exists (fold (A:=A) f s i); exact (fold_1 s i f).
+  Qed.
+
+  Definition cardinal :
+      forall s : t,
+      {r : nat | let (l,_) := elements s in r = length l }.
+  Proof.
+    intros; exists (cardinal s); exact (cardinal_1 s).
+  Qed.
+
+  Definition fdec (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+    (x : elt) := if Pdec x then true else false.
+
+  Lemma compat_P_aux :
+   forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}),
+   compat_P E.eq P -> compat_bool E.eq (fdec Pdec).
+  Proof.
+    unfold compat_P, compat_bool, Proper, respectful, fdec; intros.
+    generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder.
+  Qed.
+
+  Hint Resolve compat_P_aux : core.
+
+  Definition filter :
+    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
+    {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}.
+  Proof.
+    intros.
+    exists (filter (fdec Pdec) s).
+    intro H; assert (compat_bool E.eq (fdec Pdec)); auto.
+    intuition.
+    eauto with set.
+    generalize (filter_2 H0 H1).
+    unfold fdec.
+    case (Pdec x); intuition.
+    inversion H2.
+    apply filter_3; auto.
+    unfold fdec; simpl.
+    case (Pdec x); intuition.
+  Qed.
+
+  Definition for_all :
+    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
+    {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}.
+  Proof.
+    intros.
+    generalize (for_all_1 (s:=s) (f:=fdec Pdec))
+     (for_all_2 (s:=s) (f:=fdec Pdec)).
+    case (for_all (fdec Pdec) s); unfold For_all; [ left | right ];
+     intros.
+    assert (compat_bool E.eq (fdec Pdec)); auto.
+    generalize (H0 H3 Logic.eq_refl _ H2).
+    unfold fdec.
+    case (Pdec x); intuition.
+    inversion H4.
+    intuition.
+    absurd (false = true); [ auto with bool | apply H; auto ].
+    intro.
+    unfold fdec.
+    case (Pdec x); intuition.
+  Qed.
+
+  Definition exists_ :
+    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
+    {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}.
+  Proof.
+    intros.
+    generalize (exists_1 (s:=s) (f:=fdec Pdec))
+     (exists_2 (s:=s) (f:=fdec Pdec)).
+    case (exists_ (fdec Pdec) s); unfold Exists; [ left | right ];
+     intros.
+    elim H0; auto; intros.
+    exists x; intuition.
+    generalize H4.
+    unfold fdec.
+    case (Pdec x); intuition.
+    inversion H2.
+    intuition.
+    elim H2; intros.
+    absurd (false = true); [ auto with bool | apply H; auto ].
+    exists x; intuition.
+    unfold fdec.
+    case (Pdec x); intuition.
+  Qed.
+
+  Definition partition :
+    forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t),
+    {partition : t * t |
+    let (s1, s2) := partition in
+    compat_P E.eq P ->
+    For_all P s1 /\
+    For_all (fun x => ~ P x) s2 /\
+    (forall x : elt, In x s <-> In x s1 \/ In x s2)}.
+  Proof.
+    intros.
+    exists (partition (fdec Pdec) s).
+    generalize (partition_1 s (f:=fdec Pdec)) (partition_2 s (f:=fdec Pdec)).
+    case (partition (fdec Pdec) s).
+    intros s1 s2; simpl.
+    intros; assert (compat_bool E.eq (fdec Pdec)); auto.
+    intros; assert (compat_bool E.eq (fun x => negb (fdec Pdec x))).
+    generalize H2; unfold compat_bool, Proper, respectful; intuition;
+     apply (f_equal negb); auto.
+    intuition.
+    generalize H4; unfold For_all, Equal; intuition.
+    elim (H0 x); intros.
+    assert (fdec Pdec x = true).
+     eapply filter_2; eauto with set.
+    generalize H8; unfold fdec; case (Pdec x); intuition.
+    inversion H9.
+    generalize H; unfold For_all, Equal; intuition.
+    elim (H0 x); intros.
+    cut ((fun x => negb (fdec Pdec x)) x = true).
+    unfold fdec; case (Pdec x); intuition.
+      change ((fun x => negb (fdec Pdec x)) x = true).
+      apply (filter_2 (s:=s) (x:=x)); auto.
+    set (b := fdec Pdec x) in *; generalize (Logic.eq_refl b);
+     pattern b at -1; case b; unfold b;
+     [ left | right ].
+    elim (H4 x); intros _ B; apply B; auto with set.
+    elim (H x); intros _ B; apply B; auto with set.
+    apply filter_3; auto.
+    rewrite H5; auto.
+    eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B;
+     auto.
+    eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; auto.
+  Qed.
+
+  Definition choose_aux: forall s : t,
+    { x : elt | M.choose s = Some x } + { M.choose s = None }.
+  Proof.
+   intros.
+   destruct (M.choose s); [left | right]; auto.
+   exists e; auto.
+  Qed.
+
+  Definition choose : forall s : t, {x : elt | In x s} + {Empty s}.
+  Proof.
+   intros; destruct (choose_aux s) as [(x,Hx)|H].
+   left; exists x; apply choose_1; auto.
+   right; apply choose_2; auto.
+  Defined.
+
+  Lemma choose_ok1 :
+   forall s x, M.choose s = Some x <-> exists H:In x s,
+      choose s = inleft _ (exist (fun x => In x s) x H).
+  Proof.
+    intros s x.
+    unfold choose; split; intros.
+    destruct (choose_aux s) as [(y,Hy)|H']; try congruence.
+    replace x with y in * by congruence.
+    exists (choose_1 Hy); auto.
+    destruct H.
+    destruct (choose_aux s) as [(y,Hy)|H']; congruence.
+  Qed.
+
+  Lemma choose_ok2 :
+   forall s, M.choose s = None <-> exists H:Empty s,
+      choose s = inright _ H.
+  Proof.
+    intros s.
+    unfold choose; split; intros.
+    destruct (choose_aux s) as [(y,Hy)|H']; try congruence.
+    exists (choose_2 H'); auto.
+    destruct H.
+    destruct (choose_aux s) as [(y,Hy)|H']; congruence.
+  Qed.
+
+  Lemma choose_equal : forall s s', Equal s s' ->
+     match choose s, choose s' with
+       | inleft (exist _ x _), inleft (exist _ x' _) => E.eq x x'
+       | inright _, inright _  => True
+       | _, _                        => False
+     end.
+  Proof.
+   intros.
+   generalize (@M.choose_1 s)(@M.choose_2 s)
+              (@M.choose_1 s')(@M.choose_2 s')(@M.choose_3 s s')
+              (choose_ok1 s)(choose_ok2 s)(choose_ok1 s')(choose_ok2 s').
+   destruct (choose s) as [(x,Hx)|Hx]; destruct (choose s') as [(x',Hx')|Hx']; auto; intros.
+   apply H4; auto.
+   rewrite H5; exists Hx; auto.
+   rewrite H7; exists Hx'; auto.
+   apply Hx' with x; unfold Equal in H; rewrite <-H; auto.
+   apply Hx with x'; unfold Equal in H; rewrite H; auto.
+  Qed.
+
+  Definition min_elt :
+    forall s : t,
+    {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}.
+  Proof.
+    intros;
+     generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)).
+    case (min_elt s); [ left | right ]; auto.
+    exists e; unfold For_all; eauto.
+  Qed.
+
+  Definition max_elt :
+    forall s : t,
+    {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}.
+  Proof.
+    intros;
+     generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)).
+    case (max_elt s); [ left | right ]; auto.
+    exists e; unfold For_all; eauto.
+  Qed.
+
+  Definition elt := elt.
+  Definition t := t.
+
+  Definition In := In.
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) (s : t) :=
+    forall x : elt, In x s -> P x.
+  Definition Exists (P : elt -> Prop) (s : t) :=
+    exists x : elt, In x s /\ P x.
+
+  Definition eq_In := In_1.
+
+  Definition eq := Equal.
+  Definition lt := lt.
+  Definition eq_refl := eq_refl.
+  Definition eq_sym := eq_sym.
+  Definition eq_trans := eq_trans.
+  Definition lt_trans := lt_trans.
+  Definition lt_not_eq := lt_not_eq.
+  Definition compare := compare.
+
+  Module E := E.
+
+End DepOfNodep.
+
+
+(** * From dependent signature [Sdep] to non-dependent signature [S]. *)
+
+Module NodepOfDep (M: Sdep) <: S with Module E := M.E.
+  Import M.
+
+  Module ME := OrderedTypeFacts E.
+
+  Definition empty : t := let (s, _) := empty in s.
+
+  Lemma empty_1 : Empty empty.
+  Proof.
+    unfold empty; case M.empty; auto.
+  Qed.
+
+  Definition is_empty (s : t) : bool :=
+    if is_empty s then true else false.
+
+  Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true.
+  Proof.
+    intros; unfold is_empty; case (M.is_empty s); auto.
+  Qed.
+
+  Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s.
+  Proof.
+    intro s; unfold is_empty; case (M.is_empty s); auto.
+    intros; discriminate H.
+  Qed.
+
+  Definition mem (x : elt) (s : t) : bool :=
+    if mem x s then true else false.
+
+  Lemma mem_1 : forall (s : t) (x : elt), In x s -> mem x s = true.
+  Proof.
+    intros; unfold mem; case (M.mem x s); auto.
+  Qed.
+
+  Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s.
+  Proof.
+    intros s x; unfold mem; case (M.mem x s); auto.
+    intros; discriminate H.
+  Qed.
+
+  Definition eq_dec := equal.
+
+  Definition equal (s s' : t) : bool :=
+    if equal s s' then true else false.
+
+  Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true.
+  Proof.
+    intros; unfold equal; case M.equal; intuition.
+  Qed.
+
+  Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'.
+  Proof.
+    intros s s'; unfold equal; case (M.equal s s'); intuition;
+     inversion H.
+  Qed.
+
+  Definition subset (s s' : t) : bool :=
+    if subset s s' then true else false.
+
+  Lemma subset_1 : forall s s' : t, Subset s s' -> subset s s' = true.
+  Proof.
+    intros; unfold subset; case M.subset; intuition.
+  Qed.
+
+  Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'.
+  Proof.
+    intros s s'; unfold subset; case (M.subset s s'); intuition;
+     inversion H.
+  Qed.
+
+  Definition choose (s : t) : option elt :=
+    match choose s with
+    | inleft (exist _ x _) => Some x
+    | inright _ => None
+    end.
+
+  Lemma choose_1 : forall (s : t) (x : elt), choose s = Some x -> In x s.
+  Proof.
+    intros s x; unfold choose; case (M.choose s).
+    simple destruct s0; intros; injection H; intros; subst; auto.
+    intros; discriminate H.
+  Qed.
+
+  Lemma choose_2 : forall s : t, choose s = None -> Empty s.
+  Proof.
+    intro s; unfold choose; case (M.choose s); auto.
+    simple destruct s0; intros; discriminate H.
+  Qed.
+
+  Lemma choose_3 : forall s s' x x',
+   choose s = Some x -> choose s' = Some x' -> Equal s s' -> E.eq x x'.
+  Proof.
+  unfold choose; intros.
+  generalize (M.choose_equal H1); clear H1.
+  destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?];
+   simpl; auto; congruence.
+  Qed.
+
+  Definition elements (s : t) : list elt := let (l, _) := elements s in l.
+
+  Lemma elements_1 : forall (s : t) (x : elt), In x s -> InA E.eq x (elements s).
+  Proof.
+    intros; unfold elements; case (M.elements s); firstorder.
+  Qed.
+
+  Lemma elements_2 : forall (s : t) (x : elt), InA E.eq x (elements s) -> In x s.
+  Proof.
+    intros s x; unfold elements; case (M.elements s); firstorder.
+  Qed.
+
+  Lemma elements_3 : forall s : t, sort E.lt (elements s).
+  Proof.
+    intros; unfold elements; case (M.elements s); firstorder.
+  Qed.
+  Hint Resolve elements_3 : core.
+
+  Lemma elements_3w : forall s : t, NoDupA E.eq (elements s).
+  Proof. auto. Qed.
+
+  Definition min_elt (s : t) : option elt :=
+    match min_elt s with
+    | inleft (exist _ x _) => Some x
+    | inright _ => None
+    end.
+
+  Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s.
+  Proof.
+    intros s x; unfold min_elt; case (M.min_elt s).
+    simple destruct s0; intros; injection H; intros; subst; intuition.
+    intros; discriminate H.
+  Qed.
+
+  Lemma min_elt_2 :
+   forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x.
+  Proof.
+    intros s x y; unfold min_elt; case (M.min_elt s).
+    unfold For_all; simple destruct s0; intros; injection H; intros;
+     subst; firstorder.
+    intros; discriminate H.
+  Qed.
+
+  Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s.
+  Proof.
+    intros s; unfold min_elt; case (M.min_elt s); auto.
+    simple destruct s0; intros; discriminate H.
+  Qed.
+
+  Definition max_elt (s : t) : option elt :=
+    match max_elt s with
+    | inleft (exist _ x _) => Some x
+    | inright _ => None
+    end.
+
+  Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s.
+  Proof.
+    intros s x; unfold max_elt; case (M.max_elt s).
+    simple destruct s0; intros; injection H; intros; subst; intuition.
+    intros; discriminate H.
+  Qed.
+
+  Lemma max_elt_2 :
+   forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y.
+  Proof.
+    intros s x y; unfold max_elt; case (M.max_elt s).
+    unfold For_all; simple destruct s0; intros; injection H; intros;
+     subst; firstorder.
+    intros; discriminate H.
+  Qed.
+
+  Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s.
+  Proof.
+    intros s; unfold max_elt; case (M.max_elt s); auto.
+    simple destruct s0; intros; discriminate H.
+  Qed.
+
+  Definition add (x : elt) (s : t) : t := let (s', _) := add x s in s'.
+
+  Lemma add_1 : forall (s : t) (x y : elt), E.eq x y -> In y (add x s).
+  Proof.
+    intros; unfold add; case (M.add x s); unfold Add;
+     firstorder.
+  Qed.
+
+  Lemma add_2 : forall (s : t) (x y : elt), In y s -> In y (add x s).
+  Proof.
+    intros; unfold add; case (M.add x s); unfold Add;
+     firstorder.
+  Qed.
+
+  Lemma add_3 :
+   forall (s : t) (x y : elt), ~ E.eq x y -> In y (add x s) -> In y s.
+  Proof.
+    intros s x y; unfold add; case (M.add x s); unfold Add;
+     firstorder.
+  Qed.
+
+  Definition remove (x : elt) (s : t) : t := let (s', _) := remove x s in s'.
+
+  Lemma remove_1 : forall (s : t) (x y : elt), E.eq x y -> ~ In y (remove x s).
+  Proof.
+    intros; unfold remove; case (M.remove x s); firstorder.
+  Qed.
+
+  Lemma remove_2 :
+   forall (s : t) (x y : elt), ~ E.eq x y -> In y s -> In y (remove x s).
+  Proof.
+    intros; unfold remove; case (M.remove x s); firstorder.
+  Qed.
+
+  Lemma remove_3 : forall (s : t) (x y : elt), In y (remove x s) -> In y s.
+  Proof.
+    intros s x y; unfold remove; case (M.remove x s); firstorder.
+  Qed.
+
+  Definition singleton (x : elt) : t := let (s, _) := singleton x in s.
+
+  Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y.
+  Proof.
+    intros x y; unfold singleton; case (M.singleton x); firstorder.
+  Qed.
+
+  Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x).
+  Proof.
+    intros x y; unfold singleton; case (M.singleton x); firstorder.
+  Qed.
+
+  Definition union (s s' : t) : t := let (s'', _) := union s s' in s''.
+
+  Lemma union_1 :
+   forall (s s' : t) (x : elt), In x (union s s') -> In x s \/ In x s'.
+  Proof.
+    intros s s' x; unfold union; case (M.union s s'); firstorder.
+  Qed.
+
+  Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s').
+  Proof.
+    intros s s' x; unfold union; case (M.union s s'); firstorder.
+  Qed.
+
+  Lemma union_3 : forall (s s' : t) (x : elt), In x s' -> In x (union s s').
+  Proof.
+    intros s s' x; unfold union; case (M.union s s'); firstorder.
+  Qed.
+
+  Definition inter (s s' : t) : t := let (s'', _) := inter s s' in s''.
+
+  Lemma inter_1 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s.
+  Proof.
+    intros s s' x; unfold inter; case (M.inter s s'); firstorder.
+  Qed.
+
+  Lemma inter_2 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s'.
+  Proof.
+    intros s s' x; unfold inter; case (M.inter s s'); firstorder.
+  Qed.
+
+  Lemma inter_3 :
+   forall (s s' : t) (x : elt), In x s -> In x s' -> In x (inter s s').
+  Proof.
+    intros s s' x; unfold inter; case (M.inter s s'); firstorder.
+  Qed.
+
+  Definition diff (s s' : t) : t := let (s'', _) := diff s s' in s''.
+
+  Lemma diff_1 : forall (s s' : t) (x : elt), In x (diff s s') -> In x s.
+  Proof.
+    intros s s' x; unfold diff; case (M.diff s s'); firstorder.
+  Qed.
+
+  Lemma diff_2 : forall (s s' : t) (x : elt), In x (diff s s') -> ~ In x s'.
+  Proof.
+    intros s s' x; unfold diff; case (M.diff s s'); firstorder.
+  Qed.
+
+  Lemma diff_3 :
+   forall (s s' : t) (x : elt), In x s -> ~ In x s' -> In x (diff s s').
+  Proof.
+    intros s s' x; unfold diff; case (M.diff s s'); firstorder.
+  Qed.
+
+  Definition cardinal (s : t) : nat := let (f, _) := cardinal s in f.
+
+  Lemma cardinal_1 : forall s, cardinal s = length (elements s).
+  Proof.
+    intros; unfold cardinal; case (M.cardinal s); unfold elements in *;
+    destruct (M.elements s); auto.
+  Qed.
+
+  Definition fold (B : Type) (f : elt -> B -> B) (i : t)
+    (s : B) : B := let (fold, _) := fold f i s in fold.
+
+  Lemma fold_1 :
+   forall (s : t) (A : Type) (i : A) (f : elt -> A -> A),
+   fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof.
+    intros; unfold fold; case (M.fold f s i); unfold elements in *;
+    destruct (M.elements s); auto.
+  Qed.
+
+  Definition f_dec :
+    forall (f : elt -> bool) (x : elt), {f x = true} + {f x <> true}.
+  Proof.
+    intros; case (f x); auto with bool.
+  Defined.
+
+  Lemma compat_P_aux :
+   forall f : elt -> bool,
+   compat_bool E.eq f -> compat_P E.eq (fun x => f x = true).
+  Proof.
+     unfold compat_bool, compat_P, Proper, respectful, impl; intros;
+      rewrite <- H1; firstorder.
+  Qed.
+
+  Hint Resolve compat_P_aux : core.
+
+  Definition filter (f : elt -> bool) (s : t) : t :=
+    let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'.
+
+  Lemma filter_1 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool E.eq f -> In x (filter f s) -> In x s.
+  Proof.
+    intros s x f; unfold filter; case M.filter as (x0,Hiff); intuition.
+    generalize (Hiff (compat_P_aux H)); firstorder.
+  Qed.
+
+  Lemma filter_2 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool E.eq f -> In x (filter f s) -> f x = true.
+  Proof.
+    intros s x f; unfold filter; case M.filter as (x0,Hiff); intuition.
+    generalize (Hiff (compat_P_aux H)); firstorder.
+  Qed.
+
+  Lemma filter_3 :
+   forall (s : t) (x : elt) (f : elt -> bool),
+   compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
+  Proof.
+    intros s x f; unfold filter; case M.filter as (x0,Hiff); intuition.
+    generalize (Hiff (compat_P_aux H)); firstorder.
+  Qed.
+
+  Definition for_all (f : elt -> bool) (s : t) : bool :=
+    if for_all (P:=fun x => f x = true) (f_dec f) s
+    then true
+    else false.
+
+  Lemma for_all_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f ->
+   For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof.
+    intros s f; unfold for_all; case M.for_all; intuition; elim n;
+     auto.
+  Qed.
+
+  Lemma for_all_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f ->
+   for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof.
+    intros s f; unfold for_all; case M.for_all; intuition;
+     inversion H0.
+  Qed.
+
+  Definition exists_ (f : elt -> bool) (s : t) : bool :=
+    if exists_ (P:=fun x => f x = true) (f_dec f) s
+    then true
+    else false.
+
+  Lemma exists_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof.
+    intros s f; unfold exists_; case M.exists_; intuition; elim n;
+     auto.
+  Qed.
+
+  Lemma exists_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof.
+    intros s f; unfold exists_; case M.exists_; intuition;
+     inversion H0.
+  Qed.
+
+  Definition partition (f : elt -> bool) (s : t) :
+    t * t :=
+    let (p, _) := partition (P:=fun x => f x = true) (f_dec f) s in p.
+
+  Lemma partition_1 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
+  Proof.
+    intros s f; unfold partition; case M.partition.
+    intro p; case p; clear p; intros s1 s2 H C.
+    generalize (H (compat_P_aux C)); clear H; intro H.
+    simpl; unfold Equal; intuition.
+    apply filter_3; firstorder.
+    elim (H2 a); intros.
+    assert (In a s).
+     eapply filter_1; eauto.
+    elim H3; intros; auto.
+    absurd (f a = true).
+    exact (H a H6).
+    eapply filter_2; eauto.
+  Qed.
+
+  Lemma partition_2 :
+   forall (s : t) (f : elt -> bool),
+   compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof.
+    intros s f; unfold partition; case M.partition.
+    intro p; case p; clear p; intros s1 s2 H C.
+    generalize (H (compat_P_aux C)); clear H; intro H.
+    assert (D : compat_bool E.eq (fun x => negb (f x))).
+    generalize C; unfold compat_bool, Proper, respectful; intros; apply (f_equal negb);
+     auto.
+    simpl; unfold Equal; intuition.
+    apply filter_3; firstorder.
+    elim (H2 a); intros.
+    assert (In a s).
+     eapply filter_1; eauto.
+    elim H3; intros; auto.
+    absurd (f a = true).
+    intro.
+    generalize (filter_2 D H1).
+    rewrite H7; intros H8; inversion H8.
+    exact (H0 a H6).
+  Qed.
+
+
+  Definition elt := elt.
+  Definition t := t.
+
+  Definition In := In.
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Add (x : elt) (s s' : t) :=
+    forall y : elt, In y s' <-> E.eq y x \/ In y s.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) (s : t) :=
+    forall x : elt, In x s -> P x.
+  Definition Exists (P : elt -> Prop) (s : t) :=
+    exists x : elt, In x s /\ P x.
+
+  Definition In_1 := eq_In.
+
+  Definition eq := Equal.
+  Definition lt := lt.
+  Definition eq_refl := eq_refl.
+  Definition eq_sym := eq_sym.
+  Definition eq_trans := eq_trans.
+  Definition lt_trans := lt_trans.
+  Definition lt_not_eq := lt_not_eq.
+  Definition compare := compare.
+
+  Module E := E.
+
+End NodepOfDep.
diff --git a/theories/FSets/FSetCompat.v b/theories/FSets/FSetCompat.v
new file mode 100644
index 0000000000..736c85dada
--- /dev/null
+++ b/theories/FSets/FSetCompat.v
@@ -0,0 +1,414 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * Compatibility functors between FSetInterface and MSetInterface. *)
+
+Require Import FSetInterface FSetFacts MSetInterface MSetFacts.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * From new Weak Sets to old ones *)
+
+Module Backport_WSets
+ (E:DecidableType.DecidableType)
+ (M:MSetInterface.WSets with Definition E.t := E.t
+                        with Definition E.eq := E.eq)
+ <: FSetInterface.WSfun E.
+
+ Definition elt := E.t.
+ Definition t := M.t.
+
+ Implicit Type s : t.
+ Implicit Type x y : elt.
+ Implicit Type f : elt -> bool.
+
+ Definition In : elt -> t -> Prop := M.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.
+ Definition empty : t := M.empty.
+ Definition is_empty : t -> bool := M.is_empty.
+ Definition mem : elt -> t -> bool := M.mem.
+ Definition add : elt -> t -> t := M.add.
+ Definition singleton : elt -> t := M.singleton.
+ Definition remove : elt -> t -> t := M.remove.
+ Definition union : t -> t -> t := M.union.
+ Definition inter : t -> t -> t := M.inter.
+ Definition diff : t -> t -> t := M.diff.
+ Definition eq : t -> t -> Prop := M.eq.
+ Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec.
+ Definition equal : t -> t -> bool := M.equal.
+ Definition subset : t -> t -> bool := M.subset.
+ Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold.
+ Definition for_all : (elt -> bool) -> t -> bool := M.for_all.
+ Definition exists_ : (elt -> bool) -> t -> bool := M.exists_.
+ Definition filter : (elt -> bool) -> t -> t := M.filter.
+ Definition partition : (elt -> bool) -> t -> t * t:= M.partition.
+ Definition cardinal : t -> nat := M.cardinal.
+ Definition elements : t -> list elt := M.elements.
+ Definition choose : t -> option elt := M.choose.
+
+ Module MF := MSetFacts.WFacts M.
+
+ Definition In_1 : forall s x y, E.eq x y -> In x s -> In y s
+  := MF.In_1.
+ Definition eq_refl : forall s, eq s s
+  := @Equivalence_Reflexive _ _ M.eq_equiv.
+ Definition eq_sym : forall s s', eq s s' -> eq s' s
+  := @Equivalence_Symmetric _ _ M.eq_equiv.
+ Definition eq_trans : forall s s' s'', eq s s' -> eq s' s'' -> eq s s''
+  := @Equivalence_Transitive _ _ M.eq_equiv.
+ Definition mem_1 : forall s x, In x s -> mem x s = true
+  := MF.mem_1.
+ Definition mem_2 : forall s x, mem x s = true -> In x s
+  := MF.mem_2.
+ Definition equal_1 : forall s s', Equal s s' -> equal s s' = true
+  := MF.equal_1.
+ Definition equal_2 : forall s s', equal s s' = true -> Equal s s'
+  := MF.equal_2.
+ Definition subset_1 : forall s s', Subset s s' -> subset s s' = true
+  := MF.subset_1.
+ Definition subset_2 : forall s s', subset s s' = true -> Subset s s'
+  := MF.subset_2.
+ Definition empty_1 : Empty empty := MF.empty_1.
+ Definition is_empty_1 : forall s, Empty s -> is_empty s = true
+  := MF.is_empty_1.
+ Definition is_empty_2 : forall s, is_empty s = true -> Empty s
+  := MF.is_empty_2.
+ Definition add_1 : forall s x y, E.eq x y -> In y (add x s)
+  := MF.add_1.
+ Definition add_2 : forall s x y, In y s -> In y (add x s)
+  := MF.add_2.
+ Definition add_3 : forall s x y, ~ E.eq x y -> In y (add x s) -> In y s
+  := MF.add_3.
+ Definition remove_1 : forall s x y, E.eq x y -> ~ In y (remove x s)
+  := MF.remove_1.
+ Definition remove_2 : forall s x y, ~ E.eq x y -> In y s -> In y (remove x s)
+  := MF.remove_2.
+ Definition remove_3 : forall s x y, In y (remove x s) -> In y s
+  := MF.remove_3.
+ Definition union_1 : forall s s' x, In x (union s s') -> In x s \/ In x s'
+  := MF.union_1.
+ Definition union_2 : forall s s' x, In x s -> In x (union s s')
+  := MF.union_2.
+ Definition union_3 : forall s s' x, In x s' -> In x (union s s')
+  := MF.union_3.
+ Definition inter_1 : forall s s' x, In x (inter s s') -> In x s
+  := MF.inter_1.
+ Definition inter_2 : forall s s' x, In x (inter s s') -> In x s'
+  := MF.inter_2.
+ Definition inter_3 : forall s s' x, In x s -> In x s' -> In x (inter s s')
+  := MF.inter_3.
+ Definition diff_1 : forall s s' x, In x (diff s s') -> In x s
+  := MF.diff_1.
+ Definition diff_2 : forall s s' x, In x (diff s s') -> ~ In x s'
+  := MF.diff_2.
+ Definition diff_3 : forall s s' x, In x s -> ~ In x s' -> In x (diff s s')
+  := MF.diff_3.
+ Definition singleton_1 : forall x y, In y (singleton x) -> E.eq x y
+  := MF.singleton_1.
+ Definition singleton_2 : forall x y, E.eq x y -> In y (singleton x)
+  := MF.singleton_2.
+ Definition fold_1 : forall s (A : Type) (i : A) (f : elt -> A -> A),
+   fold f s i = fold_left (fun a e => f e a) (elements s) i
+  := MF.fold_1.
+ Definition cardinal_1 : forall s, cardinal s = length (elements s)
+  := MF.cardinal_1.
+ Definition filter_1 : forall s x f, compat_bool E.eq f ->
+  In x (filter f s) -> In x s
+  := MF.filter_1.
+ Definition filter_2 : forall s x f, compat_bool E.eq f ->
+  In x (filter f s) -> f x = true
+  := MF.filter_2.
+ Definition filter_3 : forall s x f, compat_bool E.eq f ->
+  In x s -> f x = true -> In x (filter f s)
+  := MF.filter_3.
+ Definition for_all_1 : forall s f, compat_bool E.eq f ->
+  For_all (fun x => f x = true) s -> for_all f s = true
+  := MF.for_all_1.
+ Definition for_all_2 : forall s f, compat_bool E.eq f ->
+  for_all f s = true -> For_all (fun x => f x = true) s
+  := MF.for_all_2.
+ Definition exists_1 : forall s f, compat_bool E.eq f ->
+  Exists (fun x => f x = true) s -> exists_ f s = true
+  := MF.exists_1.
+ Definition exists_2 : forall s f, compat_bool E.eq f ->
+  exists_ f s = true -> Exists (fun x => f x = true) s
+  := MF.exists_2.
+ Definition partition_1 : forall s f, compat_bool E.eq f ->
+  Equal (fst (partition f s)) (filter f s)
+  := MF.partition_1.
+ Definition partition_2 : forall s f, compat_bool E.eq f ->
+  Equal (snd (partition f s)) (filter (fun x => negb (f x)) s)
+  := MF.partition_2.
+ Definition choose_1 : forall s x, choose s = Some x -> In x s
+  := MF.choose_1.
+ Definition choose_2 : forall s, choose s = None -> Empty s
+  := MF.choose_2.
+ Definition elements_1 : forall s x, In x s -> InA E.eq x (elements s)
+  := MF.elements_1.
+ Definition elements_2 : forall s x, InA E.eq x (elements s) -> In x s
+  := MF.elements_2.
+ Definition elements_3w : forall s, NoDupA E.eq (elements s)
+  := MF.elements_3w.
+
+End Backport_WSets.
+
+
+(** * From new Sets to new ones *)
+
+Module Backport_Sets
+ (O:OrderedType.OrderedType)
+ (M:MSetInterface.Sets with Definition E.t := O.t
+                       with Definition E.eq := O.eq
+                       with Definition E.lt := O.lt)
+ <: FSetInterface.S with Module E:=O.
+
+  Include Backport_WSets O M.
+
+  Implicit Type s : t.
+  Implicit Type x y : elt.
+
+  Definition lt : t -> t -> Prop := M.lt.
+  Definition min_elt : t -> option elt := M.min_elt.
+  Definition max_elt : t -> option elt := M.max_elt.
+  Definition min_elt_1 : forall s x, min_elt s = Some x -> In x s
+   := M.min_elt_spec1.
+  Definition min_elt_2 : forall s x y,
+   min_elt s = Some x -> In y s -> ~ O.lt y x
+   := M.min_elt_spec2.
+  Definition min_elt_3 : forall s, min_elt s = None -> Empty s
+   := M.min_elt_spec3.
+  Definition max_elt_1 : forall s x, max_elt s = Some x -> In x s
+   := M.max_elt_spec1.
+  Definition max_elt_2 : forall s x y,
+   max_elt s = Some x -> In y s -> ~ O.lt x y
+   := M.max_elt_spec2.
+  Definition max_elt_3 : forall s, max_elt s = None -> Empty s
+   := M.max_elt_spec3.
+  Definition elements_3 : forall s, sort O.lt (elements s)
+   := M.elements_spec2.
+  Definition choose_3 : forall s s' x y,
+   choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y
+   := M.choose_spec3.
+  Definition lt_trans : forall s s' s'', lt s s' -> lt s' s'' -> lt s s''
+   := @StrictOrder_Transitive _ _ M.lt_strorder.
+  Lemma lt_not_eq : forall s s',  lt s s' -> ~ eq s s'.
+  Proof.
+   unfold lt, eq. intros s s' Hlt Heq. rewrite Heq in Hlt.
+   apply (StrictOrder_Irreflexive s'); auto.
+  Qed.
+  Definition compare : forall s s', Compare lt eq s s'.
+  Proof.
+   intros s s'; destruct (CompSpec2Type (M.compare_spec s s'));
+    [ apply EQ | apply LT | apply GT ]; auto.
+  Defined.
+
+  Module E := O.
+
+End Backport_Sets.
+
+
+(** * From old Weak Sets to new ones. *)
+
+Module Update_WSets
+ (E:Equalities.DecidableType)
+ (M:FSetInterface.WS with Definition E.t := E.t
+                     with Definition E.eq := E.eq)
+ <: MSetInterface.WSetsOn E.
+
+ Definition elt := E.t.
+ Definition t := M.t.
+
+ Implicit Type s : t.
+ Implicit Type x y : elt.
+ Implicit Type f : elt -> bool.
+
+ Definition In : elt -> t -> Prop := M.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.
+ Definition empty : t := M.empty.
+ Definition is_empty : t -> bool := M.is_empty.
+ Definition mem : elt -> t -> bool := M.mem.
+ Definition add : elt -> t -> t := M.add.
+ Definition singleton : elt -> t := M.singleton.
+ Definition remove : elt -> t -> t := M.remove.
+ Definition union : t -> t -> t := M.union.
+ Definition inter : t -> t -> t := M.inter.
+ Definition diff : t -> t -> t := M.diff.
+ Definition eq : t -> t -> Prop := M.eq.
+ Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec.
+ Definition equal : t -> t -> bool := M.equal.
+ Definition subset : t -> t -> bool := M.subset.
+ Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold.
+ Definition for_all : (elt -> bool) -> t -> bool := M.for_all.
+ Definition exists_ : (elt -> bool) -> t -> bool := M.exists_.
+ Definition filter : (elt -> bool) -> t -> t := M.filter.
+ Definition partition : (elt -> bool) -> t -> t * t:= M.partition.
+ Definition cardinal : t -> nat := M.cardinal.
+ Definition elements : t -> list elt := M.elements.
+ Definition choose : t -> option elt := M.choose.
+
+ Module MF := FSetFacts.WFacts M.
+
+ Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In.
+ Proof. intros x x' Hx s s' Hs. subst. apply MF.In_eq_iff; auto. Qed.
+
+ Instance eq_equiv : Equivalence eq := _.
+
+ Section Spec.
+  Variable s s': t.
+  Variable x y : elt.
+
+  Lemma mem_spec : mem x s = true <-> In x s.
+  Proof. intros; symmetry; apply MF.mem_iff. Qed.
+
+  Lemma equal_spec : equal s s' = true <-> Equal s s'.
+  Proof. intros; symmetry; apply MF.equal_iff. Qed.
+
+  Lemma subset_spec : subset s s' = true <-> Subset s s'.
+  Proof. intros; symmetry; apply MF.subset_iff. Qed.
+
+  Definition empty_spec : Empty empty := M.empty_1.
+
+  Lemma is_empty_spec : is_empty s = true <-> Empty s.
+  Proof. intros; symmetry; apply MF.is_empty_iff. Qed.
+  
+  Declare Equivalent Keys In M.In.
+
+  Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s.
+  Proof. intros. rewrite MF.add_iff. intuition. Qed.
+
+  Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x.
+  Proof. intros. rewrite MF.remove_iff. intuition. Qed.
+
+  Lemma singleton_spec : In y (singleton x) <-> E.eq y x.
+  Proof. intros; rewrite MF.singleton_iff. intuition. Qed.
+
+  Definition union_spec : In x (union s s') <-> In x s \/ In x s'
+   := @MF.union_iff s s' x.
+  Definition inter_spec : In x (inter s s') <-> In x s /\ In x s'
+   := @MF.inter_iff s s' x.
+  Definition diff_spec : In x (diff s s') <-> In x s /\ ~In x s'
+   := @MF.diff_iff s s' x.
+  Definition fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A),
+   fold f s i = fold_left (flip f) (elements s) i
+   := @M.fold_1 s.
+  Definition cardinal_spec : cardinal s = length (elements s)
+   := @M.cardinal_1 s.
+
+  Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s.
+  Proof. intros; symmetry; apply MF.elements_iff. Qed.
+
+  Definition elements_spec2w : NoDupA E.eq (elements s)
+   := @M.elements_3w s.
+  Definition choose_spec1 : choose s = Some x -> In x s
+   := @M.choose_1 s x.
+  Definition choose_spec2 : choose s = None -> Empty s
+   := @M.choose_2 s.
+  Definition filter_spec : forall f, Proper (E.eq==>Logic.eq) f ->
+   (In x (filter f s) <-> In x s /\ f x = true)
+   := @MF.filter_iff s x.
+  Definition partition_spec1 : forall f, Proper (E.eq==>Logic.eq) f ->
+   Equal (fst (partition f s)) (filter f s)
+   := @M.partition_1 s.
+  Definition partition_spec2 : forall f, Proper (E.eq==>Logic.eq) f ->
+   Equal (snd (partition f s)) (filter (fun x => negb (f x)) s)
+   := @M.partition_2 s.
+
+  Lemma for_all_spec : forall f, Proper (E.eq==>Logic.eq) f ->
+    (for_all f s = true <-> For_all (fun x => f x = true) s).
+  Proof. intros; symmetry; apply MF.for_all_iff; auto. Qed.
+
+  Lemma exists_spec : forall f, Proper (E.eq==>Logic.eq) f ->
+    (exists_ f s = true <-> Exists (fun x => f x = true) s).
+  Proof. intros; symmetry; apply MF.exists_iff; auto. Qed.
+
+  End Spec.
+
+End Update_WSets.
+
+
+(** * From old Sets to new ones. *)
+
+Module Update_Sets
+ (O:Orders.OrderedType)
+ (M:FSetInterface.S with Definition E.t := O.t
+                    with Definition E.eq := O.eq
+                    with Definition E.lt := O.lt)
+ <: MSetInterface.Sets with Module E:=O.
+
+  Include Update_WSets O M.
+
+  Implicit Type s : t.
+  Implicit Type x y : elt.
+
+  Definition lt : t -> t -> Prop := M.lt.
+  Definition min_elt : t -> option elt := M.min_elt.
+  Definition max_elt : t -> option elt := M.max_elt.
+  Definition min_elt_spec1 : forall s x, min_elt s = Some x -> In x s
+   := M.min_elt_1.
+  Definition min_elt_spec2 : forall s x y,
+   min_elt s = Some x -> In y s -> ~ O.lt y x
+   := M.min_elt_2.
+  Definition min_elt_spec3 : forall s, min_elt s = None -> Empty s
+   := M.min_elt_3.
+  Definition max_elt_spec1 : forall s x, max_elt s = Some x -> In x s
+   := M.max_elt_1.
+  Definition max_elt_spec2 : forall s x y,
+   max_elt s = Some x -> In y s -> ~ O.lt x y
+   := M.max_elt_2.
+  Definition max_elt_spec3 : forall s, max_elt s = None -> Empty s
+   := M.max_elt_3.
+  Definition elements_spec2 : forall s, sort O.lt (elements s)
+   := M.elements_3.
+  Definition choose_spec3 : forall s s' x y,
+   choose s = Some x -> choose s' = Some y -> Equal s s' -> O.eq x y
+   := M.choose_3.
+
+  Instance lt_strorder : StrictOrder lt.
+  Proof.
+   split.
+   intros x Hx. apply (M.lt_not_eq Hx); auto with *.
+   exact M.lt_trans.
+  Qed.
+
+  Instance lt_compat : Proper (eq==>eq==>iff) lt.
+  Proof.
+  apply proper_sym_impl_iff_2; auto with *.
+  intros s s' Hs u u' Hu H.
+  assert (H0 : lt s' u).
+   destruct (M.compare s' u) as [H'|H'|H']; auto.
+   elim (M.lt_not_eq H). transitivity s'; auto with *.
+   elim (M.lt_not_eq (M.lt_trans H H')); auto.
+  destruct (M.compare s' u') as [H'|H'|H']; auto.
+  elim (M.lt_not_eq H).
+   transitivity u'; auto with *. transitivity s'; auto with *.
+  elim (M.lt_not_eq (M.lt_trans H' H0)); auto with *.
+  Qed.
+
+  Definition compare s s' :=
+   match M.compare s s' with
+    | EQ _ => Eq
+    | LT _ => Lt
+    | GT _ => Gt
+   end.
+
+  Lemma compare_spec : forall s s', CompSpec eq lt s s' (compare s s').
+  Proof. intros; unfold compare; destruct M.compare; auto. Qed.
+
+  Module E := O.
+
+End Update_Sets.
diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v
new file mode 100644
index 0000000000..83bb07ffb6
--- /dev/null
+++ b/theories/FSets/FSetDecide.v
@@ -0,0 +1,899 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(**************************************************************)
+(* FSetDecide.v                                               *)
+(*                                                            *)
+(* Author: Aaron Bohannon                                     *)
+(**************************************************************)
+
+(** This file implements a decision procedure for a certain
+    class of propositions involving finite sets.  *)
+
+Require Import Decidable Setoid DecidableTypeEx FSetFacts.
+
+(** First, a version for Weak Sets in functorial presentation *)
+
+Module WDecide_fun (E : DecidableType)(Import M : WSfun E).
+ Module F := FSetFacts.WFacts_fun E M.
+
+(** * Overview
+    This functor defines the tactic [fsetdec], which will
+    solve any valid goal of the form
+<<
+    forall s1 ... sn,
+    forall x1 ... xm,
+    P1 -> ... -> Pk -> P
+>>
+    where [P]'s are defined by the grammar:
+<<
+
+P ::=
+| Q
+| Empty F
+| Subset F F'
+| Equal F F'
+
+Q ::=
+| E.eq X X'
+| In X F
+| Q /\ Q'
+| Q \/ Q'
+| Q -> Q'
+| Q <-> Q'
+| ~ Q
+| True
+| False
+
+F ::=
+| S
+| empty
+| singleton X
+| add X F
+| remove X F
+| union F F'
+| inter F F'
+| diff F F'
+
+X ::= x1 | ... | xm
+S ::= s1 | ... | sn
+
+>>
+
+The tactic will also work on some goals that vary slightly from
+the above form:
+- The variables and hypotheses may be mixed in any order and may
+  have already been introduced into the context.  Moreover,
+  there may be additional, unrelated hypotheses mixed in (these
+  will be ignored).
+- A conjunction of hypotheses will be handled as easily as
+  separate hypotheses, i.e., [P1 /\ P2 -> P] can be solved iff
+  [P1 -> P2 -> P] can be solved.
+- [fsetdec] should solve any goal if the FSet-related hypotheses
+  are contradictory.
+- [fsetdec] will first perform any necessary zeta and beta
+  reductions and will invoke [subst] to eliminate any Coq
+  equalities between finite sets or their elements.
+- If [E.eq] is convertible with Coq's equality, it will not
+  matter which one is used in the hypotheses or conclusion.
+- The tactic can solve goals where the finite sets or set
+  elements are expressed by Coq terms that are more complicated
+  than variables.  However, non-local definitions are not
+  expanded, and Coq equalities between non-variable terms are
+  not used.  For example, this goal will be solved:
+<<
+    forall (f : t -> t),
+    forall (g : elt -> elt),
+    forall (s1 s2 : t),
+    forall (x1 x2 : elt),
+    Equal s1 (f s2) ->
+    E.eq x1 (g (g x2)) ->
+    In x1 s1 ->
+    In (g (g x2)) (f s2)
+>>
+  This one will not be solved:
+<<
+    forall (f : t -> t),
+    forall (g : elt -> elt),
+    forall (s1 s2 : t),
+    forall (x1 x2 : elt),
+    Equal s1 (f s2) ->
+    E.eq x1 (g x2) ->
+    In x1 s1 ->
+    g x2 = g (g x2) ->
+    In (g (g x2)) (f s2)
+>>
+*)
+
+  (** * Facts and Tactics for Propositional Logic
+      These lemmas and tactics are in a module so that they do
+      not affect the namespace if you import the enclosing
+      module [Decide]. *)
+  Module FSetLogicalFacts.
+    Export Decidable.
+    Export Setoid.
+
+    (** ** Lemmas and Tactics About Decidable Propositions *)
+
+    (** ** Propositional Equivalences Involving Negation
+        These are all written with the unfolded form of
+        negation, since I am not sure if setoid rewriting will
+        always perform conversion. *)
+
+    (** ** Tactics for Negations *)
+
+    Tactic Notation "fold" "any" "not" :=
+      repeat (
+        match goal with
+        | H: context [?P -> False] |- _ =>
+          fold (~ P) in H
+        | |- context [?P -> False] =>
+          fold (~ P)
+        end).
+
+    (** [push not using db] will pushes all negations to the
+        leaves of propositions in the goal, using the lemmas in
+        [db] to assist in checking the decidability of the
+        propositions involved.  If [using db] is omitted, then
+        [core] will be used.  Additional versions are provided
+        to manipulate the hypotheses or the hypotheses and goal
+        together.
+
+        XXX: This tactic and the similar subsequent ones should
+        have been defined using [autorewrite]. However, dealing
+        with multiples rewrite sites and side-conditions is
+        done more cleverly with the following explicit
+        analysis of goals. *)
+
+    Ltac or_not_l_iff P Q tac :=
+      (rewrite (or_not_l_iff_1 P Q) by tac) ||
+      (rewrite (or_not_l_iff_2 P Q) by tac).
+
+    Ltac or_not_r_iff P Q tac :=
+      (rewrite (or_not_r_iff_1 P Q) by tac) ||
+      (rewrite (or_not_r_iff_2 P Q) by tac).
+
+    Ltac or_not_l_iff_in P Q H tac :=
+      (rewrite (or_not_l_iff_1 P Q) in H by tac) ||
+      (rewrite (or_not_l_iff_2 P Q) in H by tac).
+
+    Ltac or_not_r_iff_in P Q H tac :=
+      (rewrite (or_not_r_iff_1 P Q) in H by tac) ||
+      (rewrite (or_not_r_iff_2 P Q) in H by tac).
+
+    Tactic Notation "push" "not" "using" ident(db) :=
+      let dec := solve_decidable using db in
+      unfold not, iff;
+      repeat (
+        match goal with
+        | |- context [True -> False] => rewrite not_true_iff
+        | |- context [False -> False] => rewrite not_false_iff
+        | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec
+        | |- context [(?P -> False) -> (?Q -> False)] =>
+            rewrite (contrapositive P Q) by dec
+        | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec
+        | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec
+        | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec
+        | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q)
+        | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q)
+        | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec
+        end);
+      fold any not.
+
+    Tactic Notation "push" "not" :=
+      push not using core.
+
+    Tactic Notation
+      "push" "not" "in" "*" "|-" "using" ident(db) :=
+      let dec := solve_decidable using db in
+      unfold not, iff in * |-;
+      repeat (
+        match goal with
+        | H: context [True -> False] |- _ => rewrite not_true_iff in H
+        | H: context [False -> False] |- _ => rewrite not_false_iff in H
+        | H: context [(?P -> False) -> False] |- _ =>
+          rewrite (not_not_iff P) in H by dec
+        | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
+          rewrite (contrapositive P Q) in H by dec
+        | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec
+        | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec
+        | H: context [(?P -> False) -> ?Q] |- _ =>
+          rewrite (imp_not_l P Q) in H by dec
+        | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H
+        | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H
+        | H: context [(?P -> ?Q) -> False] |- _ =>
+          rewrite (not_imp_iff P Q) in H by dec
+        end);
+      fold any not.
+
+    Tactic Notation "push" "not" "in" "*" "|-"  :=
+      push not in * |- using core.
+
+    Tactic Notation "push" "not" "in" "*" "using" ident(db) :=
+      push not using db; push not in * |- using db.
+    Tactic Notation "push" "not" "in" "*" :=
+      push not in * using core.
+
+    (** A simple test case to see how this works.  *)
+    Lemma test_push : forall P Q R : Prop,
+      decidable P ->
+      decidable Q ->
+      (~ True) ->
+      (~ False) ->
+      (~ ~ P) ->
+      (~ (P /\ Q) -> ~ R) ->
+      ((P /\ Q) \/ ~ R) ->
+      (~ (P /\ Q) \/ R) ->
+      (R \/ ~ (P /\ Q)) ->
+      (~ R \/ (P /\ Q)) ->
+      (~ P -> R) ->
+      (~ ((R -> P) \/ (Q -> R))) ->
+      (~ (P /\ R)) ->
+      (~ (P -> R)) ->
+      True.
+    Proof.
+      intros. push not in *.
+       (* note that ~(R->P) remains (since R isnt decidable) *)
+      tauto.
+    Qed.
+
+    (** [pull not using db] will pull as many negations as
+        possible toward the top of the propositions in the goal,
+        using the lemmas in [db] to assist in checking the
+        decidability of the propositions involved.  If [using
+        db] is omitted, then [core] will be used.  Additional
+        versions are provided to manipulate the hypotheses or
+        the hypotheses and goal together. *)
+
+    Tactic Notation "pull" "not" "using" ident(db) :=
+      let dec := solve_decidable using db in
+      unfold not, iff;
+      repeat (
+        match goal with
+        | |- context [True -> False] => rewrite not_true_iff
+        | |- context [False -> False] => rewrite not_false_iff
+        | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec
+        | |- context [(?P -> False) -> (?Q -> False)] =>
+          rewrite (contrapositive P Q) by dec
+        | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec
+        | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec
+        | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec
+        | |- context [(?P -> False) /\ (?Q -> False)] =>
+          rewrite <- (not_or_iff P Q)
+        | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q)
+        | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec
+        | |- context [(?Q -> False) /\ ?P] =>
+          rewrite <- (not_imp_rev_iff P Q) by dec
+        end);
+      fold any not.
+
+    Tactic Notation "pull" "not" :=
+      pull not using core.
+
+    Tactic Notation
+      "pull" "not" "in" "*" "|-" "using" ident(db) :=
+      let dec := solve_decidable using db in
+      unfold not, iff in * |-;
+      repeat (
+        match goal with
+        | H: context [True -> False] |- _ => rewrite not_true_iff in H
+        | H: context [False -> False] |- _ => rewrite not_false_iff in H
+        | H: context [(?P -> False) -> False] |- _ =>
+          rewrite (not_not_iff P) in H by dec
+        | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
+          rewrite (contrapositive P Q) in H by dec
+        | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec
+        | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec
+        | H: context [(?P -> False) -> ?Q] |- _ =>
+          rewrite (imp_not_l P Q) in H by dec
+        | H: context [(?P -> False) /\ (?Q -> False)] |- _ =>
+          rewrite <- (not_or_iff P Q) in H
+        | H: context [?P -> ?Q -> False] |- _ =>
+          rewrite <- (not_and_iff P Q) in H
+        | H: context [?P /\ (?Q -> False)] |- _ =>
+          rewrite <- (not_imp_iff P Q) in H by dec
+        | H: context [(?Q -> False) /\ ?P] |- _ =>
+          rewrite <- (not_imp_rev_iff P Q) in H by dec
+        end);
+      fold any not.
+
+    Tactic Notation "pull" "not" "in" "*" "|-"  :=
+      pull not in * |- using core.
+
+    Tactic Notation "pull" "not" "in" "*" "using" ident(db) :=
+      pull not using db; pull not in * |- using db.
+    Tactic Notation "pull" "not" "in" "*" :=
+      pull not in * using core.
+
+    (** A simple test case to see how this works.  *)
+    Lemma test_pull : forall P Q R : Prop,
+      decidable P ->
+      decidable Q ->
+      (~ True) ->
+      (~ False) ->
+      (~ ~ P) ->
+      (~ (P /\ Q) -> ~ R) ->
+      ((P /\ Q) \/ ~ R) ->
+      (~ (P /\ Q) \/ R) ->
+      (R \/ ~ (P /\ Q)) ->
+      (~ R \/ (P /\ Q)) ->
+      (~ P -> R) ->
+      (~ (R -> P) /\ ~ (Q -> R)) ->
+      (~ P \/ ~ R) ->
+      (P /\ ~ R) ->
+      (~ R /\ P) ->
+      True.
+    Proof.
+      intros. pull not in *. tauto.
+    Qed.
+
+  End FSetLogicalFacts.
+  Import FSetLogicalFacts.
+
+  (** * Auxiliary Tactics
+      Again, these lemmas and tactics are in a module so that
+      they do not affect the namespace if you import the
+      enclosing module [Decide].  *)
+  Module FSetDecideAuxiliary.
+
+    (** ** Generic Tactics
+        We begin by defining a few generic, useful tactics. *)
+
+    (** remove logical hypothesis inter-dependencies (fix #2136). *)
+
+    Ltac no_logical_interdep :=
+      match goal with
+        | H : ?P |- _ =>
+          match type of P with
+            | Prop =>
+              match goal with H' : context [ H ] |- _ => clear dependent H' end
+            | _ => fail
+          end; no_logical_interdep
+        | _ => idtac
+      end.
+
+    Ltac abstract_term t :=
+      tryif (is_var t) then fail "no need to abstract a variable"
+      else (let x := fresh "x" in set (x := t) in *; try clearbody x).
+
+    Ltac abstract_elements :=
+      repeat
+        (match goal with
+           | |- context [ singleton ?t ] => abstract_term t
+           | _ : context [ singleton ?t ] |- _ => abstract_term t
+           | |- context [ add ?t _ ] => abstract_term t
+           | _ : context [ add ?t _ ] |- _ => abstract_term t
+           | |- context [ remove ?t _ ] => abstract_term t
+           | _ : context [ remove ?t _ ] |- _ => abstract_term t
+           | |- context [ In ?t _ ] => abstract_term t
+           | _ : context [ In ?t _ ] |- _ => abstract_term t
+         end).
+
+    (** [prop P holds by t] succeeds (but does not modify the
+        goal or context) if the proposition [P] can be proved by
+        [t] in the current context.  Otherwise, the tactic
+        fails. *)
+    Tactic Notation "prop" constr(P) "holds" "by" tactic(t) :=
+      let H := fresh in
+      assert P as H by t;
+      clear H.
+
+    (** This tactic acts just like [assert ... by ...] but will
+        fail if the context already contains the proposition. *)
+    Tactic Notation "assert" "new" constr(e) "by" tactic(t) :=
+      match goal with
+      | H: e |- _ => fail 1
+      | _ => assert e by t
+      end.
+
+    (** [subst++] is similar to [subst] except that
+        - it never fails (as [subst] does on recursive
+          equations),
+        - it substitutes locally defined variable for their
+          definitions,
+        - it performs beta reductions everywhere, which may
+          arise after substituting a locally defined function
+          for its definition.
+        *)
+    Tactic Notation "subst" "++" :=
+      repeat (
+        match goal with
+        | x : _ |- _ => subst x
+        end);
+      cbv zeta beta in *.
+
+    (** [decompose records] calls [decompose record H] on every
+        relevant hypothesis [H]. *)
+    Tactic Notation "decompose" "records" :=
+      repeat (
+        match goal with
+        | H: _ |- _ => progress (decompose record H); clear H
+        end).
+
+    (** ** Discarding Irrelevant Hypotheses
+        We will want to clear the context of any
+        non-FSet-related hypotheses in order to increase the
+        speed of the tactic.  To do this, we will need to be
+        able to decide which are relevant.  We do this by making
+        a simple inductive definition classifying the
+        propositions of interest. *)
+
+    Inductive FSet_elt_Prop : Prop -> Prop :=
+    | eq_Prop : forall (S : Type) (x y : S),
+        FSet_elt_Prop (x = y)
+    | eq_elt_prop : forall x y,
+        FSet_elt_Prop (E.eq x y)
+    | In_elt_prop : forall x s,
+        FSet_elt_Prop (In x s)
+    | True_elt_prop :
+        FSet_elt_Prop True
+    | False_elt_prop :
+        FSet_elt_Prop False
+    | conj_elt_prop : forall P Q,
+        FSet_elt_Prop P ->
+        FSet_elt_Prop Q ->
+        FSet_elt_Prop (P /\ Q)
+    | disj_elt_prop : forall P Q,
+        FSet_elt_Prop P ->
+        FSet_elt_Prop Q ->
+        FSet_elt_Prop (P \/ Q)
+    | impl_elt_prop : forall P Q,
+        FSet_elt_Prop P ->
+        FSet_elt_Prop Q ->
+        FSet_elt_Prop (P -> Q)
+    | not_elt_prop : forall P,
+        FSet_elt_Prop P ->
+        FSet_elt_Prop (~ P).
+
+    Inductive FSet_Prop : Prop -> Prop :=
+    | elt_FSet_Prop : forall P,
+        FSet_elt_Prop P ->
+        FSet_Prop P
+    | Empty_FSet_Prop : forall s,
+        FSet_Prop (Empty s)
+    | Subset_FSet_Prop : forall s1 s2,
+        FSet_Prop (Subset s1 s2)
+    | Equal_FSet_Prop : forall s1 s2,
+        FSet_Prop (Equal s1 s2).
+
+    (** Here is the tactic that will throw away hypotheses that
+        are not useful (for the intended scope of the [fsetdec]
+        tactic). *)
+    Hint Constructors FSet_elt_Prop FSet_Prop : FSet_Prop.
+    Ltac discard_nonFSet :=
+      repeat (
+        match goal with
+        | H : context [ @Logic.eq ?T ?x ?y ] |- _ =>
+          tryif (change T with E.t in H) then fail
+          else tryif (change T with t in H) then fail
+          else clear H
+        | H : ?P |- _ =>
+          tryif prop (FSet_Prop P) holds by
+            (auto 100 with FSet_Prop)
+          then fail
+          else clear H
+        end).
+
+    (** ** Turning Set Operators into Propositional Connectives
+        The lemmas from [FSetFacts] will be used to break down
+        set operations into propositional formulas built over
+        the predicates [In] and [E.eq] applied only to
+        variables.  We are going to use them with [autorewrite].
+        *)
+
+    Hint Rewrite
+      F.empty_iff F.singleton_iff F.add_iff F.remove_iff
+      F.union_iff F.inter_iff F.diff_iff
+    : set_simpl.
+
+    Lemma eq_refl_iff (x : E.t) : E.eq x x <-> True.
+    Proof.
+     now split.
+    Qed.
+
+    Hint Rewrite eq_refl_iff : set_eq_simpl.
+
+    (** ** Decidability of FSet Propositions *)
+
+    (** [In] is decidable. *)
+    Lemma dec_In : forall x s,
+      decidable (In x s).
+    Proof.
+      red; intros; generalize (F.mem_iff s x); case (mem x s); intuition.
+    Qed.
+
+    (** [E.eq] is decidable. *)
+    Lemma dec_eq : forall (x y : E.t),
+      decidable (E.eq x y).
+    Proof.
+      red; intros x y; destruct (E.eq_dec x y); auto.
+    Qed.
+
+    (** The hint database [FSet_decidability] will be given to
+        the [push_neg] tactic from the module [Negation]. *)
+    Hint Resolve dec_In dec_eq : FSet_decidability.
+
+    (** ** Normalizing Propositions About Equality
+        We have to deal with the fact that [E.eq] may be
+        convertible with Coq's equality.  Thus, we will find the
+        following tactics useful to replace one form with the
+        other everywhere. *)
+
+    (** The next tactic, [Logic_eq_to_E_eq], mentions the term
+        [E.t]; thus, we must ensure that [E.t] is used in favor
+        of any other convertible but syntactically distinct
+        term. *)
+    Ltac change_to_E_t :=
+      repeat (
+        match goal with
+        | H : ?T |- _ =>
+          progress (change T with E.t in H);
+          repeat (
+            match goal with
+            | J : _ |- _ => progress (change T with E.t in J)
+            | |- _ => progress (change T with E.t)
+            end )
+        | 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 substFSet :=
+      repeat (
+        match goal with
+        | H: E.eq ?x ?x |- _ => clear H
+        | H: E.eq ?x ?y |- _ => rewrite H in *; clear H
+        end);
+      autorewrite with set_eq_simpl in *.
+
+    (** ** Considering Decidability of Base Propositions
+        This tactic adds assertions about the decidability of
+        [E.eq] and [In] to the context.  This is necessary for
+        the completeness of the [fsetdec] tactic.  However, in
+        order to minimize the cost of proof search, we should be
+        careful to not add more than we need.  Once negations
+        have been pushed to the leaves of the propositions, we
+        only need to worry about decidability for those base
+        propositions that appear in a negated form. *)
+    Ltac assert_decidability :=
+      (** We actually don't want these rules to fire if the
+          syntactic context in the patterns below is trivially
+          empty, but we'll just do some clean-up at the
+          afterward.  *)
+      repeat (
+        match goal with
+        | H: context [~ E.eq ?x ?y] |- _ =>
+          assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq)
+        | H: context [~ In ?x ?s] |- _ =>
+          assert new (In x s \/ ~ In x s) by (apply dec_In)
+        | |- context [~ E.eq ?x ?y] =>
+          assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq)
+        | |- context [~ In ?x ?s] =>
+          assert new (In x s \/ ~ In x s) by (apply dec_In)
+        end);
+      (** Now we eliminate the useless facts we added (because
+          they would likely be very harmful to performance). *)
+      repeat (
+        match goal with
+        | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H
+        end).
+
+    (** ** Handling [Empty], [Subset], and [Equal]
+        This tactic instantiates universally quantified
+        hypotheses (which arise from the unfolding of [Empty],
+        [Subset], and [Equal]) for each of the set element
+        expressions that is involved in some membership or
+        equality fact.  Then it throws away those hypotheses,
+        which should no longer be needed. *)
+    Ltac inst_FSet_hypotheses :=
+      repeat (
+        match goal with
+        | H : forall a : E.t, _,
+          _ : context [ In ?x _ ] |- _ =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _
+          |- context [ In ?x _ ] =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _,
+          _ : context [ E.eq ?x _ ] |- _ =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _
+          |- context [ E.eq ?x _ ] =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _,
+          _ : context [ E.eq _ ?x ] |- _ =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        | H : forall a : E.t, _
+          |- context [ E.eq _ ?x ] =>
+          let P := type of (H x) in
+          assert new P by (exact (H x))
+        end);
+      repeat (
+        match goal with
+        | H : forall a : E.t, _ |- _ =>
+          clear H
+        end).
+
+    (** ** The Core [fsetdec] Auxiliary Tactics *)
+
+    (** Here is the crux of the proof search.  Recursion through
+        [intuition]!  (This will terminate if I correctly
+        understand the behavior of [intuition].) *)
+    Ltac fsetdec_rec := progress substFSet; intuition fsetdec_rec.
+
+    (** If we add [unfold Empty, Subset, Equal in *; intros;] to
+        the beginning of this tactic, it will satisfy the same
+        specification as the [fsetdec] tactic; however, it will
+        be much slower than necessary without the pre-processing
+        done by the wrapper tactic [fsetdec]. *)
+    Ltac fsetdec_body :=
+      autorewrite with set_eq_simpl in *;
+      inst_FSet_hypotheses;
+      autorewrite with set_simpl set_eq_simpl in *;
+      push not in * using FSet_decidability;
+      substFSet;
+      assert_decidability;
+      auto;
+      (intuition fsetdec_rec) ||
+      fail 1
+        "because the goal is beyond the scope of this tactic".
+
+  End FSetDecideAuxiliary.
+  Import FSetDecideAuxiliary.
+
+  (** * The [fsetdec] Tactic
+      Here is the top-level tactic (the only one intended for
+      clients of this library).  It's specification is given at
+      the top of the file. *)
+  Ltac fsetdec :=
+    (** We first unfold any occurrences of [iff]. *)
+    unfold iff in *;
+    (** We fold occurrences of [not] because it is better for
+        [intros] to leave us with a goal of [~ P] than a goal of
+        [False]. *)
+    fold any not; intros;
+    (** We don't care about the value of elements : complex ones are
+        abstracted as new variables (avoiding potential dependencies,
+        see bug #2464) *)
+    abstract_elements;
+    (** We remove dependencies to logical hypothesis. This way,
+        later "clear" will work nicely (see bug #2136) *)
+    no_logical_interdep;
+    (** Now we decompose conjunctions, which will allow the
+        [discard_nonFSet] and [assert_decidability] tactics to
+        do a much better job. *)
+    decompose records;
+    discard_nonFSet;
+    (** We unfold these defined propositions on finite sets.  If
+        our goal was one of them, then have one more item to
+        introduce now. *)
+    unfold Empty, Subset, Equal in *; intros;
+    (** We now want to get rid of all uses of [=] in favor of
+        [E.eq].  However, the best way to eliminate a [=] is in
+        the context is with [subst], so we will try that first.
+        In fact, we may as well convert uses of [E.eq] into [=]
+        when possible before we do [subst] so that we can even
+        more mileage out of it.  Then we will convert all
+        remaining uses of [=] back to [E.eq] when possible.  We
+        use [change_to_E_t] to ensure that we have a canonical
+        name for set elements, so that [Logic_eq_to_E_eq] will
+        work properly.  *)
+    change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq;
+    (** The next optimization is to swap a negated goal with a
+        negated hypothesis when possible.  Any swap will improve
+        performance by eliminating the total number of
+        negations, but we will get the maximum benefit if we
+        swap the goal with a hypotheses mentioning the same set
+        element, so we try that first.  If we reach the fourth
+        branch below, we attempt any swap.  However, to maintain
+        completeness of this tactic, we can only perform such a
+        swap with a decidable proposition; hence, we first test
+        whether the hypothesis is an [FSet_elt_Prop], noting
+        that any [FSet_elt_Prop] is decidable. *)
+    pull not using FSet_decidability;
+    unfold not in *;
+    match goal with
+    | H: (In ?x ?r) -> False |- (In ?x ?s) -> False =>
+      contradict H; fsetdec_body
+    | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False =>
+      contradict H; fsetdec_body
+    | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False =>
+      contradict H; fsetdec_body
+    | H: ?P -> False |- ?Q -> False =>
+      tryif prop (FSet_elt_Prop P) holds by
+        (auto 100 with FSet_Prop)
+      then (contradict H; fsetdec_body)
+      else fsetdec_body
+    | |- _ =>
+      fsetdec_body
+    end.
+
+  (** * Examples *)
+
+  Module FSetDecideTestCases.
+
+    Lemma test_eq_trans_1 : forall x y z s,
+      E.eq x y ->
+      ~ ~ E.eq z y ->
+      In x s ->
+      In z s.
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_trans_2 : forall x y z r s,
+      In x (singleton y) ->
+      ~ In z r ->
+      ~ ~ In z (add y r) ->
+      In x s ->
+      In z s.
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_neq_trans_1 : forall w x y z s,
+      E.eq x w ->
+      ~ ~ E.eq x y ->
+      ~ E.eq y z ->
+      In w s ->
+      In w (remove z s).
+    Proof. fsetdec. Qed.
+
+    Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s,
+      In x (singleton w) ->
+      ~ In x r1 ->
+      In x (add y r1) ->
+      In y r2 ->
+      In y (remove z r2) ->
+      In w s ->
+      In w (remove z s).
+    Proof. fsetdec. Qed.
+
+    Lemma test_In_singleton : forall x,
+      In x (singleton x).
+    Proof. fsetdec. Qed.
+
+    Lemma test_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 FSetDecideTestCases.
+
+End WDecide_fun.
+
+Require Import FSetInterface.
+
+(** 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:WS) := !WDecide_fun M.E M.
+Module Decide := WDecide.
diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v
new file mode 100644
index 0000000000..3f8840529e
--- /dev/null
+++ b/theories/FSets/FSetEqProperties.v
@@ -0,0 +1,939 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * Finite sets library *)
+
+(** This module proves many properties of finite sets that
+    are consequences of the axiomatization in [FsetInterface]
+    Contrary to the functor in [FsetProperties] it uses
+    sets operations instead of predicates over sets, i.e.
+    [mem x s=true] instead of [In x s],
+    [equal s s'=true] instead of [Equal s s'], etc. *)
+
+Require Import FSetProperties Zerob Sumbool Omega DecidableTypeEx.
+
+Module WEqProperties_fun (Import E:DecidableType)(M:WSfun E).
+Module Import MP := WProperties_fun 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 fset.
+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 Logic.eq_refl); 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 fset.
+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.
+
+(* characterisation 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.
+
+(* characterisation 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:compat_op E.eq 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 fset.
+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 Logic.eq_refl)) 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.
+assert (E.eq x y -> f y = true) by
+ (intro H0; rewrite <- (Comp _ _ H0); auto).
+tauto.
+Qed.
+
+Lemma add_filter_2 : forall s s' x,
+ f x=false -> (Add x s s') -> filter f s [=] filter f s'.
+Proof.
+unfold Add, MP.Add, Equal; intros.
+repeat rewrite filter_iff; auto.
+rewrite H0; clear H0.
+assert (f a = true -> ~E.eq x a).
+ intros H0 H1.
+ rewrite (Comp _ _ H1) in H.
+ rewrite H in H0; discriminate.
+tauto.
+Qed.
+
+Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) ->
+  forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s.
+Proof.
+clear Comp' Comp f.
+intros.
+assert (compat_bool E.eq (fun x => orb (f x) (g x))).
+  unfold compat_bool, Proper, respectful; 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: compat_bool E.eq f.
+
+Let Comp' : compat_bool E.eq (fun x =>negb (f x)).
+Proof.
+unfold compat_bool, Proper, respectful in *; intros; f_equal; auto.
+Qed.
+
+Lemma exists_mem_1:
+ forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false.
+Proof.
+intros.
+rewrite for_all_exists; auto.
+rewrite for_all_mem_1;auto with bool.
+intros;generalize (H x H0);intros.
+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.
+destruct (for_all_mem_4 (fun x =>negb (f x)) Comp' s) as (x,p); 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 := (compat_op E.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))).  red; auto with fset.
+assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros; omega.
+assert (gc : compat_opL (fun x:elt => plus (g x))). red; auto with fset.
+assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega.
+assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). repeat red; auto.
+assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega.
+assert (st : Equivalence (@Logic.eq nat)) by (split; congruence).
+intros s;pattern s; apply set_rec.
+intros.
+rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H).
+rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H).
+rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto.
+intros; do 3 (rewrite (fold_add _ _ st);auto).
+rewrite H0;simpl;omega.
+do 3 rewrite fold_empty;auto.
+Qed.
+
+Lemma sum_filter : forall f, (compat_bool E.eq f) ->
+  forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)).
+Proof.
+unfold sum; intros f Hf.
+assert (st : Equivalence (@Logic.eq nat)) by (split; congruence).
+assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))).
+ repeat red; intros.
+ rewrite (Hf _ _ H); auto.
+assert (ct : transposeL (fun x => plus (if f x then 1 else 0))).
+ red; intros; omega.
+intros s;pattern s; apply set_rec.
+intros.
+change elt with E.t.
+rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H).
+rewrite <- (MP.Equal_cardinal (filter_equal Hf (equal_2 H))); auto.
+intros; rewrite (fold_add _ _ st _ cc ct); auto.
+generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) .
+assert (~ In x (filter f s0)).
+ intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H.
+case (f x); simpl; intros.
+rewrite (MP.cardinal_2 H1 (H2 Logic.eq_refl (MP.Add_add s0 x))); auto.
+rewrite <- (MP.Equal_cardinal (H3 Logic.eq_refl (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),
+  (compat_op E.eq eqA f) -> (transpose eqA f) ->
+  (compat_op E.eq eqA g) -> (transpose eqA g) ->
+  forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) ->
+  (eqA (fold f s i) (fold g s i)).
+Proof.
+intros A eqA st f g fc ft gc gt i.
+intro s; pattern s; apply set_rec; intros.
+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 *.
+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)); auto with *.
+intros x x' Hx y y' Hy. rewrite Hx, Hy; auto.
+intros x x' Hx y y' Hy. rewrite Hx, Hy; auto.
+Qed.
+
+End Sum.
+
+End WEqProperties_fun.
+
+(** 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:WS) := WEqProperties_fun M.E M.
+Module EqProperties := WEqProperties.
diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v
new file mode 100644
index 0000000000..f4d281e937
--- /dev/null
+++ b/theories/FSets/FSetFacts.v
@@ -0,0 +1,493 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * Finite sets library *)
+
+(** This functor derives additional facts from [FSetInterface.S]. These
+  facts are mainly the specifications of [FSetInterface.S] written using
+  different styles: equivalence and boolean equalities.
+  Moreover, we prove that [E.Eq] and [Equal] are setoid equalities.
+*)
+
+Require Import DecidableTypeEx.
+Require Export FSetInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** First, a functor for Weak Sets in functorial version. *)
+
+Module WFacts_fun (Import E : DecidableType)(Import M : WSfun E).
+
+Notation eq_dec := E.eq_dec.
+Definition eqb x y := if eq_dec x y then true else false.
+
+(** * Specifications written using equivalences *)
+
+Section IffSpec.
+Variable s s' s'' : t.
+Variable x y z : elt.
+
+Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s).
+Proof.
+split; apply In_1; auto.
+Qed.
+
+Lemma mem_iff : In x s <-> mem x s = true.
+Proof.
+split; [apply mem_1|apply mem_2].
+Qed.
+
+Lemma not_mem_iff : ~In x s <-> mem x s = false.
+Proof.
+rewrite mem_iff; destruct (mem x s); intuition.
+Qed.
+
+Lemma equal_iff : s[=]s' <-> equal s s' = true.
+Proof.
+split; [apply equal_1|apply equal_2].
+Qed.
+
+Lemma subset_iff : s[<=]s' <-> subset s s' = true.
+Proof.
+split; [apply subset_1|apply subset_2].
+Qed.
+
+Lemma empty_iff : In x empty <-> False.
+Proof.
+intuition; apply (empty_1 H).
+Qed.
+
+Lemma is_empty_iff : Empty s <-> is_empty s = true.
+Proof.
+split; [apply is_empty_1|apply is_empty_2].
+Qed.
+
+Lemma singleton_iff : In y (singleton x) <-> E.eq x y.
+Proof.
+split; [apply singleton_1|apply singleton_2].
+Qed.
+
+Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s.
+Proof.
+split; [ | destruct 1; [apply add_1|apply add_2]]; auto.
+destruct (eq_dec x y) as [E|E]; auto.
+intro H; right; exact (add_3 E H).
+Qed.
+
+Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s)  <-> In y s).
+Proof.
+split; [apply add_3|apply add_2]; auto.
+Qed.
+
+Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y.
+Proof.
+split; [split; [apply remove_3 with x |] | destruct 1; apply remove_2]; auto.
+intro.
+apply (remove_1 H0 H).
+Qed.
+
+Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s).
+Proof.
+split; [apply remove_3|apply remove_2]; auto.
+Qed.
+
+Lemma union_iff : In x (union s s') <-> In x s \/ In x s'.
+Proof.
+split; [apply union_1 | destruct 1; [apply union_2|apply union_3]]; auto.
+Qed.
+
+Lemma inter_iff : In x (inter s s') <-> In x s /\ In x s'.
+Proof.
+split; [split; [apply inter_1 with s' | apply inter_2 with s] | destruct 1; apply inter_3]; auto.
+Qed.
+
+Lemma diff_iff : In x (diff s s') <-> In x s /\ ~ In x s'.
+Proof.
+split; [split; [apply diff_1 with s' | apply diff_2 with s] | destruct 1; apply diff_3]; auto.
+Qed.
+
+Variable f : elt->bool.
+
+Lemma filter_iff :  compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true).
+Proof.
+split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto.
+Qed.
+
+Lemma for_all_iff : compat_bool E.eq f ->
+  (For_all (fun x => f x = true) s <-> for_all f s = true).
+Proof.
+split; [apply for_all_1 | apply for_all_2]; auto.
+Qed.
+
+Lemma exists_iff : compat_bool E.eq f ->
+  (Exists (fun x => f x = true) s <-> exists_ f s = true).
+Proof.
+split; [apply exists_1 | apply exists_2]; auto.
+Qed.
+
+Lemma elements_iff : In x s <-> InA E.eq x (elements s).
+Proof.
+split; [apply elements_1 | apply elements_2].
+Qed.
+
+End IffSpec.
+
+(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *)
+
+Ltac set_iff :=
+ repeat (progress (
+  rewrite add_iff || rewrite remove_iff || rewrite singleton_iff
+  || rewrite union_iff || rewrite inter_iff || rewrite diff_iff
+  || rewrite empty_iff)).
+
+(**  * Specifications written using boolean predicates *)
+
+Section BoolSpec.
+Variable s s' s'' : t.
+Variable x y z : elt.
+
+Lemma mem_b : E.eq x y -> mem x s = mem y s.
+Proof.
+intros.
+generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H).
+destruct (mem x s); destruct (mem y s); intuition.
+Qed.
+
+Lemma empty_b : mem y empty = false.
+Proof.
+generalize (empty_iff y)(mem_iff empty y).
+destruct (mem y empty); intuition.
+Qed.
+
+Lemma add_b : mem y (add x s) = eqb x y || mem y s.
+Proof.
+generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition.
+Qed.
+
+Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s.
+Proof.
+intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H).
+destruct (mem y s); destruct (mem y (add x s)); intuition.
+Qed.
+
+Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y).
+Proof.
+generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition.
+Qed.
+
+Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s.
+Proof.
+intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H).
+destruct (mem y s); destruct (mem y (remove x s)); intuition.
+Qed.
+
+Lemma singleton_b : mem y (singleton x) = eqb x y.
+Proof.
+generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb.
+destruct (eq_dec x y); destruct (mem y (singleton x)); intuition.
+Qed.
+
+Lemma union_b : mem x (union s s') = mem x s || mem x s'.
+Proof.
+generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition.
+Qed.
+
+Lemma inter_b : mem x (inter s s') = mem x s && mem x s'.
+Proof.
+generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition.
+Qed.
+
+Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s').
+Proof.
+generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x).
+destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition.
+Qed.
+
+Lemma elements_b : mem x s = existsb (eqb x) (elements s).
+Proof.
+generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)).
+rewrite InA_alt.
+destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros.
+symmetry.
+rewrite H1.
+destruct H0 as (H0,_).
+destruct H0 as (a,(Ha1,Ha2)); [ intuition |].
+exists a; intuition.
+unfold eqb; destruct (eq_dec x a); auto.
+rewrite <- H.
+rewrite H0.
+destruct H1 as (H1,_).
+destruct H1 as (a,(Ha1,Ha2)); [intuition|].
+exists a; intuition.
+unfold eqb in *; destruct (eq_dec x a); auto; discriminate.
+Qed.
+
+Variable f : elt->bool.
+
+Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x.
+Proof.
+intros.
+generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H).
+destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition.
+Qed.
+
+Lemma for_all_b : compat_bool E.eq f ->
+  for_all f s = forallb f (elements s).
+Proof.
+intros.
+generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s).
+unfold For_all.
+destruct (forallb f (elements s)); destruct (for_all f s); auto; intros.
+rewrite <- H1; intros.
+destruct H0 as (H0,_).
+rewrite (H2 x0) in H3.
+rewrite (InA_alt E.eq x0 (elements s)) in H3.
+destruct H3 as (a,(Ha1,Ha2)).
+rewrite (H _ _ Ha1).
+apply H0; auto.
+symmetry.
+rewrite H0; intros.
+destruct H1 as (_,H1).
+apply H1; auto.
+rewrite H2.
+rewrite InA_alt; eauto.
+Qed.
+
+Lemma exists_b : compat_bool E.eq f ->
+  exists_ f s = existsb f (elements s).
+Proof.
+intros.
+generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s).
+unfold Exists.
+destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros.
+rewrite <- H1; intros.
+destruct H0 as (H0,_).
+destruct H0 as (a,(Ha1,Ha2)); auto.
+exists a; split; auto.
+rewrite H2; rewrite InA_alt; eauto.
+symmetry.
+rewrite H0.
+destruct H1 as (_,H1).
+destruct H1 as (a,(Ha1,Ha2)); auto.
+rewrite (H2 a) in Ha1.
+rewrite (InA_alt E.eq a (elements s)) in Ha1.
+destruct Ha1 as (b,(Hb1,Hb2)).
+exists b; auto.
+rewrite <- (H _ _ Hb1); auto.
+Qed.
+
+End BoolSpec.
+
+(** * [E.eq] and [Equal] are setoid equalities *)
+
+Instance E_ST : Equivalence E.eq.
+Proof.
+constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans].
+Qed.
+
+Instance Equal_ST : Equivalence Equal.
+Proof.
+constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans].
+Qed.
+
+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 is_empty_m : Proper (Equal==> Logic.eq) is_empty.
+Proof.
+unfold Equal; intros s s' H.
+generalize (is_empty_iff s)(is_empty_iff s').
+destruct (is_empty s); destruct (is_empty s');
+ unfold Empty; auto; intros.
+symmetry.
+rewrite <- H1; intros a Ha.
+rewrite <- (H a) in Ha.
+destruct H0 as (_,H0).
+exact (H0 Logic.eq_refl _ Ha).
+rewrite <- H0; intros a Ha.
+rewrite (H a) in Ha.
+destruct H1 as (_,H1).
+exact (H1 Logic.eq_refl _ Ha).
+Qed.
+
+Instance Empty_m : Proper (Equal ==> iff) Empty.
+Proof.
+repeat red; intros; do 2 rewrite is_empty_iff; rewrite H; intuition.
+Qed.
+
+Instance mem_m : Proper (E.eq ==> Equal ==> Logic.eq) mem.
+Proof.
+unfold Equal; intros x y H s s' H0.
+generalize (H0 x); clear H0; rewrite (In_eq_iff s' H).
+generalize (mem_iff s x)(mem_iff s' y).
+destruct (mem x s); destruct (mem y s'); intuition.
+Qed.
+
+Instance singleton_m : Proper (E.eq ==> Equal) singleton.
+Proof.
+unfold Equal; intros x y H a.
+do 2 rewrite singleton_iff; split; intros.
+apply E.eq_trans with x; auto.
+apply E.eq_trans with y; auto.
+Qed.
+
+Instance add_m : Proper (E.eq==>Equal==>Equal) add.
+Proof.
+unfold Equal; intros x y H s s' H0 a.
+do 2 rewrite add_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Instance remove_m : Proper (E.eq==>Equal==>Equal) remove.
+Proof.
+unfold Equal; intros x y H s s' H0 a.
+do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Instance union_m : Proper (Equal==>Equal==>Equal) union.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite union_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Instance inter_m : Proper (Equal==>Equal==>Equal) inter.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition.
+Qed.
+
+Instance diff_m : Proper (Equal==>Equal==>Equal) diff.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite diff_iff; rewrite H; rewrite H0; 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 s s' H s'' s''' H0.
+generalize (subset_iff s s'') (subset_iff s' s''').
+destruct (subset s s''); destruct (subset s' s'''); auto; intros.
+rewrite H in H1; rewrite H0 in H1; intuition.
+rewrite H in H1; rewrite H0 in H1; intuition.
+Qed.
+
+Instance equal_m : Proper (Equal ==> Equal ==> Logic.eq) equal.
+Proof.
+intros s s' H s'' s''' H0.
+generalize (equal_iff s s'') (equal_iff s' s''').
+destruct (equal s s''); destruct (equal s' s'''); auto; intros.
+rewrite H in H1; rewrite H0 in H1; intuition.
+rewrite H in H1; rewrite H0 in H1; intuition.
+Qed.
+
+
+(* [Subset] is a setoid order *)
+
+Lemma Subset_refl : forall s, s[<=]s.
+Proof. red; auto. Qed.
+
+Lemma Subset_trans : forall s s' s'', s[<=]s'->s'[<=]s''->s[<=]s''.
+Proof. unfold Subset; eauto. Qed.
+
+Add Relation t Subset
+ reflexivity proved by Subset_refl
+ transitivity proved by Subset_trans
+ as SubsetSetoid.
+
+Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> Basics.impl) In | 1.
+Proof.
+  simpl_relation. eauto with set.
+Qed.
+
+Add Morphism Empty with signature Subset --> Basics.impl as Empty_s_m.
+Proof.
+unfold Subset, Empty, Basics.impl; firstorder.
+Qed.
+
+Add Morphism add with signature E.eq ==> Subset ++> Subset as add_s_m.
+Proof.
+unfold Subset; intros x y H s s' H0 a.
+do 2 rewrite add_iff; rewrite H; intuition.
+Qed.
+
+Add Morphism remove with signature E.eq ==> Subset ++> Subset as remove_s_m.
+Proof.
+unfold Subset; intros x y H s s' H0 a.
+do 2 rewrite remove_iff; rewrite H; intuition.
+Qed.
+
+Add Morphism union with signature Subset ++> Subset ++> Subset as union_s_m.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite union_iff; intuition.
+Qed.
+
+Add Morphism inter with signature Subset ++> Subset ++> Subset as inter_s_m.
+Proof.
+unfold Equal; intros s s' H s'' s''' H0 a.
+do 2 rewrite inter_iff; intuition.
+Qed.
+
+Add Morphism diff with signature Subset ++> Subset --> Subset as diff_s_m.
+Proof.
+unfold Subset; intros s s' H s'' s''' H0 a.
+do 2 rewrite diff_iff; intuition.
+Qed.
+
+(* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism
+   without additional hypothesis on [f]. For instance: *)
+
+Lemma filter_equal : forall f, compat_bool E.eq f ->
+  forall s s', s[=]s' -> filter f s [=] filter f s'.
+Proof.
+unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto.
+Qed.
+
+Lemma filter_ext : forall f f', compat_bool E.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. do 2 (rewrite filter_iff; auto).
+rewrite Hff', Hss'; intuition.
+repeat red; intros; rewrite <- 2 Hff'; auto.
+Qed.
+
+Lemma filter_subset : forall f, compat_bool E.eq f ->
+  forall s s', s[<=]s' -> filter f s [<=] filter f s'.
+Proof.
+unfold Subset; intros; rewrite filter_iff in *; intuition.
+Qed.
+
+(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid
+   structures on [list elt] and [option elt]. *)
+
+(* Later:
+Add Morphism cardinal ; cardinal_m.
+*)
+
+End WFacts_fun.
+
+(** 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:WS) := WFacts_fun M.E M.
+Module Facts := WFacts.
diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v
new file mode 100644
index 0000000000..fa7f1c5f4e
--- /dev/null
+++ b/theories/FSets/FSetInterface.v
@@ -0,0 +1,508 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * 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:
+    - [WSfun] : functorial signature for weak sets, non-dependent style
+    - [WS]    : self-contained version of [WSfun]
+    - [Sfun]  : functorial signature for ordered sets, non-dependent style
+    - [S]     : self-contained version of [Sfun]
+    - [Sdep]  : analog of [S] written using dependent style
+
+    If unsure, [S] is probably what you're looking for: other signatures
+    are subsets of it, apart from [Sdep] which is isomorphic to [S] (see
+    [FSetBridge]).
+*)
+
+Require Export Bool OrderedType DecidableType.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** * Non-dependent signatures
+
+    The following signatures presents sets as purely informative
+    programs together with axioms *)
+
+
+
+(** ** Functorial signature for weak sets
+
+    Weak sets are sets without ordering on base elements, only
+    a decidable equality. *)
+
+Module Type WSfun (E : DecidableType).
+
+  Definition elt := E.t.
+
+  Parameter t : Type. (** the abstract type of sets *)
+
+  (** Logical predicates *)
+  Parameter In : elt -> t -> Prop.
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+
+  Notation "s  [=]  t" := (Equal s t) (at level 70, no associativity).
+  Notation "s  [<=]  t" := (Subset s t) (at level 70, no associativity).
+
+  Parameter empty : t.
+  (** The empty set. *)
+
+  Parameter is_empty : t -> bool.
+  (** Test whether a set is empty or not. *)
+
+  Parameter mem : elt -> t -> bool.
+  (** [mem x s] tests whether [x] belongs to the set [s]. *)
+
+  Parameter add : elt -> t -> t.
+  (** [add x s] returns a set containing all elements of [s],
+  plus [x]. If [x] was already in [s], [s] is returned unchanged. *)
+
+  Parameter singleton : elt -> t.
+  (** [singleton x] returns the one-element set containing only [x]. *)
+
+  Parameter remove : elt -> t -> t.
+  (** [remove x s] returns a set containing all elements of [s],
+  except [x]. If [x] was not in [s], [s] is returned unchanged. *)
+
+  Parameter union : t -> t -> t.
+  (** Set union. *)
+
+  Parameter inter : t -> t -> t.
+  (** Set intersection. *)
+
+  Parameter diff : t -> t -> t.
+  (** Set difference. *)
+
+  Definition eq : t -> t -> Prop := Equal.
+
+  Parameter eq_dec : forall s s', { eq s s' } + { ~ eq s s' }.
+
+  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. *)
+
+  Section Spec.
+
+  Variable s s' s'': t.
+  Variable x y : elt.
+
+  (** Specification of [In] *)
+  Parameter In_1 : E.eq x y -> In x s -> In y s.
+
+  (** Specification of [eq] *)
+  Parameter eq_refl : eq s s.
+  Parameter eq_sym : eq s s' -> eq s' s.
+  Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''.
+
+  (** Specification of [mem] *)
+  Parameter mem_1 : In x s -> mem x s = true.
+  Parameter mem_2 : mem x s = true -> In x s.
+
+  (** Specification of [equal] *)
+  Parameter equal_1 : Equal s s' -> equal s s' = true.
+  Parameter equal_2 : equal s s' = true -> Equal s s'.
+
+  (** Specification of [subset] *)
+  Parameter subset_1 : Subset s s' -> subset s s' = true.
+  Parameter subset_2 : subset s s' = true -> Subset s s'.
+
+  (** Specification of [empty] *)
+  Parameter empty_1 : Empty empty.
+
+  (** Specification of [is_empty] *)
+  Parameter is_empty_1 : Empty s -> is_empty s = true.
+  Parameter is_empty_2 : is_empty s = true -> Empty s.
+
+  (** Specification of [add] *)
+  Parameter add_1 : E.eq x y -> In y (add x s).
+  Parameter add_2 : In y s -> In y (add x s).
+  Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s.
+
+  (** Specification of [remove] *)
+  Parameter remove_1 : E.eq x y -> ~ In y (remove x s).
+  Parameter remove_2 : ~ E.eq x y -> In y s -> In y (remove x s).
+  Parameter remove_3 : In y (remove x s) -> In y s.
+
+  (** Specification of [singleton] *)
+  Parameter singleton_1 : In y (singleton x) -> E.eq x y.
+  Parameter singleton_2 : E.eq x y -> In y (singleton x).
+
+  (** Specification of [union] *)
+  Parameter union_1 : In x (union s s') -> In x s \/ In x s'.
+  Parameter union_2 : In x s -> In x (union s s').
+  Parameter union_3 : In x s' -> In x (union s s').
+
+  (** Specification of [inter] *)
+  Parameter inter_1 : In x (inter s s') -> In x s.
+  Parameter inter_2 : In x (inter s s') -> In x s'.
+  Parameter inter_3 : In x s -> In x s' -> In x (inter s s').
+
+  (** Specification of [diff] *)
+  Parameter diff_1 : In x (diff s s') -> In x s.
+  Parameter diff_2 : In x (diff s s') -> ~ In x s'.
+  Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s').
+
+  (** Specification of [fold] *)
+  Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+
+  (** Specification of [cardinal] *)
+  Parameter cardinal_1 : cardinal s = length (elements s).
+
+  Section Filter.
+
+  Variable f : elt -> bool.
+
+  (** Specification of [filter] *)
+  Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s.
+  Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true.
+  Parameter filter_3 :
+      compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s).
+
+  (** Specification of [for_all] *)
+  Parameter for_all_1 :
+      compat_bool E.eq f ->
+      For_all (fun x => f x = true) s -> for_all f s = true.
+  Parameter for_all_2 :
+      compat_bool E.eq f ->
+      for_all f s = true -> For_all (fun x => f x = true) s.
+
+  (** Specification of [exists] *)
+  Parameter exists_1 :
+      compat_bool E.eq f ->
+      Exists (fun x => f x = true) s -> exists_ f s = true.
+  Parameter exists_2 :
+      compat_bool E.eq f ->
+      exists_ f s = true -> Exists (fun x => f x = true) s.
+
+  (** Specification of [partition] *)
+  Parameter partition_1 :
+      compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s).
+  Parameter partition_2 :
+      compat_bool E.eq f ->
+      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+
+  End Filter.
+
+  (** Specification of [elements] *)
+  Parameter elements_1 : In x s -> InA E.eq x (elements s).
+  Parameter elements_2 : InA E.eq x (elements s) -> In x s.
+  (** When compared with ordered sets, here comes the only
+      property that is really weaker: *)
+  Parameter elements_3w : NoDupA E.eq (elements s).
+
+  (** Specification of [choose] *)
+  Parameter choose_1 : choose s = Some x -> In x s.
+  Parameter choose_2 : choose s = None -> Empty s.
+
+  End Spec.
+
+  Hint Transparent elt : core.
+  Hint Resolve mem_1 equal_1 subset_1 empty_1
+    is_empty_1 choose_1 choose_2 add_1 add_2 remove_1
+    remove_2 singleton_2 union_1 union_2 union_3
+    inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1
+    partition_1 partition_2 elements_1 elements_3w
+    : set.
+  Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3
+    remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2
+    filter_1 filter_2 for_all_2 exists_2 elements_2
+    : set.
+
+End WSfun.
+
+
+
+(** ** Static signature for weak sets
+
+    Similar to the functorial signature [SW], except that the
+    module [E] of base elements is incorporated in the signature. *)
+
+Module Type WS.
+  Declare Module E : DecidableType.
+  Include WSfun E.
+End WS.
+
+
+
+(** ** Functorial signature for sets on ordered elements
+
+    Based on [WSfun], plus ordering on sets and [min_elt] and [max_elt]
+    and some stronger specifications for other functions. *)
+
+Module Type Sfun (E : OrderedType).
+  Include WSfun E.
+
+  Parameter lt : t -> t -> Prop.
+  Parameter compare : forall s s' : t, Compare lt eq s s'.
+  (** Total ordering between sets. Can be used as the ordering function
+  for doing sets of sets. *)
+
+  Parameter min_elt : t -> option elt.
+  (** Return the smallest element of the given set
+  (with respect to the [E.compare] ordering),
+  or [None] if the set is empty. *)
+
+  Parameter max_elt : t -> option elt.
+  (** Same as [min_elt], but returns the largest element of the
+  given set. *)
+
+  Section Spec.
+
+  Variable s s' s'' : t.
+  Variable x y : elt.
+
+  (** Specification of [lt] *)
+  Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''.
+  Parameter lt_not_eq : lt s s' -> ~ eq s s'.
+
+  (** Additional specification of [elements] *)
+  Parameter elements_3 : sort E.lt (elements s).
+
+  (** Remark: since [fold] is specified via [elements], this stronger
+   specification of [elements] has an indirect impact on [fold],
+   which can now be proved to receive elements in increasing order.
+  *)
+
+  (** Specification of [min_elt] *)
+  Parameter min_elt_1 : min_elt s = Some x -> In x s.
+  Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x.
+  Parameter min_elt_3 : min_elt s = None -> Empty s.
+
+  (** Specification of [max_elt] *)
+  Parameter max_elt_1 : max_elt s = Some x -> In x s.
+  Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y.
+  Parameter max_elt_3 : max_elt s = None -> Empty s.
+
+  (** Additional specification of [choose] *)
+  Parameter choose_3 : choose s = Some x -> choose s' = Some y ->
+    Equal s s' -> E.eq x y.
+
+  End Spec.
+
+  Hint Resolve elements_3 : set.
+  Hint Immediate
+    min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3 : set.
+
+End Sfun.
+
+
+(** ** Static signature for sets on ordered elements
+
+    Similar to the functorial signature [Sfun], except that the
+    module [E] of base elements is incorporated in the signature. *)
+
+Module Type S.
+  Declare Module E : OrderedType.
+  Include Sfun E.
+End S.
+
+
+(** ** Some subtyping tests
+<<
+WSfun ---> WS
+ |         |
+ |         |
+ V         V
+Sfun  ---> S
+
+Module S_WS (M : S) <: WS := M.
+Module Sfun_WSfun (E:OrderedType)(M : Sfun E) <: WSfun E := M.
+Module S_Sfun (M : S) <: Sfun M.E := M.
+Module WS_WSfun (M : WS) <: WSfun M.E := M.
+>>
+*)
+
+(** * Dependent signature
+
+    Signature [Sdep] presents ordered sets using dependent types *)
+
+Module Type Sdep.
+
+  Declare Module E : OrderedType.
+  Definition elt := E.t.
+
+  Parameter t : Type.
+
+  Parameter In : elt -> t -> Prop.
+  Definition Equal s s' := forall a : elt, In a s <-> In a s'.
+  Definition Subset s s' := forall a : elt, In a s -> In a s'.
+  Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s.
+  Definition Empty s := forall a : elt, ~ In a s.
+  Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x.
+  Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x.
+
+  Notation "s [=] t" := (Equal s t) (at level 70, no associativity).
+
+  Definition eq : t -> t -> Prop := Equal.
+  Parameter lt : t -> t -> Prop.
+  Parameter compare : forall s s' : t, Compare lt eq s s'.
+
+  Parameter eq_refl : forall s : t, eq s s.
+  Parameter eq_sym : forall s s' : t, eq s s' -> eq s' s.
+  Parameter eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''.
+  Parameter lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''.
+  Parameter lt_not_eq : forall s s' : t, lt s s' -> ~ eq s s'.
+
+  Parameter eq_In : forall (s : t) (x y : elt), E.eq x y -> In x s -> In y s.
+
+  Parameter empty : {s : t | Empty s}.
+
+  Parameter is_empty : forall s : t, {Empty s} + {~ Empty s}.
+
+  Parameter mem : forall (x : elt) (s : t), {In x s} + {~ In x s}.
+
+  Parameter add : forall (x : elt) (s : t), {s' : t | Add x s s'}.
+
+  Parameter
+    singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}.
+
+  Parameter
+    remove :
+      forall (x : elt) (s : t),
+      {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}.
+
+  Parameter
+    union :
+      forall s s' : t,
+      {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}.
+
+  Parameter
+    inter :
+      forall s s' : t,
+      {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}.
+
+  Parameter
+    diff :
+      forall s s' : t,
+      {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}.
+
+  Parameter equal : forall s s' : t, {s[=]s'} + {~ s[=]s'}.
+
+  Parameter subset : forall s s' : t, {Subset s s'} + {~ Subset s s'}.
+
+  Parameter
+    filter :
+      forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+        (s : t),
+      {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}.
+
+  Parameter
+    for_all :
+      forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+        (s : t),
+      {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}.
+
+  Parameter
+    exists_ :
+      forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+        (s : t),
+      {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}.
+
+  Parameter
+    partition :
+      forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x})
+        (s : t),
+      {partition : t * t |
+      let (s1, s2) := partition in
+      compat_P E.eq P ->
+      For_all P s1 /\
+      For_all (fun x => ~ P x) s2 /\
+      (forall x : elt, In x s <-> In x s1 \/ In x s2)}.
+
+  Parameter
+    elements :
+      forall s : t,
+      {l : list elt |
+      sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}.
+
+  Parameter
+    fold :
+      forall (A : Type) (f : elt -> A -> A) (s : t) (i : A),
+      {r : A | let (l,_) := elements s in
+                  r = fold_left (fun a e => f e a) l i}.
+
+  Parameter
+    cardinal :
+      forall s : t,
+      {r : nat | let (l,_) := elements s in r = length l }.
+
+  Parameter
+    min_elt :
+      forall s : t,
+      {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}.
+
+  Parameter
+    max_elt :
+      forall s : t,
+      {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}.
+
+  Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}.
+
+  (** The [choose_3] specification of [S] cannot be packed
+        in the dependent version of [choose], so we leave it separate. *)
+  Parameter choose_equal : forall s s', Equal s s' ->
+     match choose s, choose s' with
+       | inleft (exist _ x _), inleft (exist _ x' _) => E.eq x x'
+       | inright _, inright _  => True
+       | _, _  => False
+     end.
+
+End Sdep.
+
diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v
new file mode 100644
index 0000000000..2036d360aa
--- /dev/null
+++ b/theories/FSets/FSetList.v
@@ -0,0 +1,29 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * Finite sets library *)
+
+(** This file proposes an implementation of the non-dependent
+    interface [FSetInterface.S] using strictly ordered list. *)
+
+Require Export FSetInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** This is just a compatibility layer, the real implementation
+    is now in [MSetList] *)
+
+Require FSetCompat MSetList Orders OrdersAlt.
+
+Module Make (X: OrderedType) <: S with Module E := X.
+ Module X' := OrdersAlt.Update_OT X.
+ Module MSet := MSetList.Make X'.
+ Include FSetCompat.Backport_Sets X MSet.
+End Make.
diff --git a/theories/FSets/FSetPositive.v b/theories/FSets/FSetPositive.v
new file mode 100644
index 0000000000..8a93f38164
--- /dev/null
+++ b/theories/FSets/FSetPositive.v
@@ -0,0 +1,1168 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** Efficient implementation of [FSetInterface.S] for positive keys,
+    inspired from the [FMapPositive] module.
+
+   This module was adapted by Alexandre Ren, Damien Pous, and Thomas
+   Braibant (2010, LIG, CNRS, UMR 5217), from the [FMapPositive]
+   module of Pierre Letouzey and Jean-Christophe Filliâtre, which in
+   turn comes from the [FMap] framework of a work by Xavier Leroy and
+   Sandrine Blazy (used for building certified compilers).
+*)
+
+Require Import Bool BinPos OrderedType OrderedTypeEx FSetInterface.
+
+Set Implicit Arguments.
+Local Open Scope lazy_bool_scope.
+Local Open Scope positive_scope.
+Local Unset Elimination Schemes.
+
+Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
+
+  Module E:=PositiveOrderedTypeBits.
+
+  Definition elt := positive : Type.
+
+  Inductive tree :=
+    | Leaf : tree
+    | Node : tree -> bool -> tree -> tree.
+
+  Scheme tree_ind := Induction for tree Sort Prop.
+
+  Definition t := tree : Type.
+
+  Definition empty : t := Leaf.
+
+  Fixpoint is_empty (m : t) : bool :=
+   match m with
+    | Leaf => true
+    | Node l b r => negb b &&& is_empty l &&& is_empty r
+   end.
+
+  Fixpoint mem (i : elt) (m : t) {struct m} : bool :=
+    match m with
+    | Leaf => false
+    | Node l o r =>
+        match i with
+        | 1 => o
+        | i~0 => mem i l
+        | i~1 => mem i r
+        end
+    end.
+
+  Fixpoint add (i : elt) (m : t) : t :=
+    match m with
+    | Leaf =>
+        match i with
+        | 1 => Node Leaf true Leaf
+        | i~0 => Node (add i Leaf) false Leaf
+        | i~1 => Node Leaf false (add i Leaf)
+        end
+    | Node l o r =>
+        match i with
+        | 1 => Node l true r
+        | i~0 => Node (add i l) o r
+        | i~1 => Node l o (add i r)
+        end
+    end.
+
+  Definition singleton i := add i empty.
+
+  (** helper function to avoid creating empty trees that are not leaves *)
+
+  Definition node (l : t) (b: bool) (r : t) : t :=
+    if b then Node l b r else
+     match l,r with
+       | Leaf,Leaf => Leaf
+       | _,_ => Node l false r end.
+
+  Fixpoint remove (i : elt) (m : t) {struct m} : t :=
+    match m with
+      | Leaf => Leaf
+      | Node l o r =>
+        match i with
+          | 1 => node l false r
+          | i~0 => node (remove i l) o r
+          | i~1 => node l o (remove i r)
+        end
+    end.
+
+  Fixpoint union (m m': t) : t :=
+    match m with
+      | Leaf => m'
+      | Node l o r =>
+        match m' with
+          | Leaf => m
+          | Node l' o' r' => Node (union l l') (o||o') (union r r')
+        end
+    end.
+
+  Fixpoint inter (m m': t) : t :=
+    match m with
+      | Leaf => Leaf
+      | Node l o r =>
+        match m' with
+          | Leaf => Leaf
+          | Node l' o' r' => node (inter l l') (o&&o') (inter r r')
+        end
+    end.
+
+  Fixpoint diff (m m': t) : t :=
+    match m with
+      | Leaf => Leaf
+      | Node l o r =>
+        match m' with
+          | Leaf => m
+          | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r')
+        end
+    end.
+
+  Fixpoint equal (m m': t): bool :=
+    match m with
+      | Leaf => is_empty m'
+      | Node l o r =>
+        match m' with
+          | Leaf => is_empty m
+          | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r'
+        end
+    end.
+
+  Fixpoint subset (m m': t): bool :=
+    match m with
+      | Leaf => true
+      | Node l o r =>
+        match m' with
+          | Leaf => is_empty m
+          | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r'
+        end
+    end.
+
+  (** reverses [y] and concatenate it with [x] *)
+
+  Fixpoint rev_append (y x : elt) : elt :=
+    match y with
+      | 1 => x
+      | y~1 => rev_append y x~1
+      | y~0 => rev_append y x~0
+    end.
+  Infix "@" := rev_append (at level 60).
+  Definition rev x := x@1.
+
+  Section Fold.
+
+    Variable B : Type.
+    Variable f : elt -> B -> B.
+
+    (** the additional argument, [i], records the current path, in
+       reverse order (this should be more efficient: we reverse this argument
+       only at present nodes only, rather than at each node of the tree).
+       we also use this convention in all functions below
+     *)
+
+    Fixpoint xfold (m : t) (v : B) (i : elt) :=
+      match m with
+        | Leaf => v
+        | Node l true r =>
+          xfold r (f (rev i) (xfold l v i~0)) i~1
+        | Node l false r =>
+          xfold r (xfold l v i~0) i~1
+      end.
+    Definition fold m i := xfold m i 1.
+
+  End Fold.
+
+  Section Quantifiers.
+
+    Variable f : elt -> bool.
+
+    Fixpoint xforall (m : t) (i : elt) :=
+      match m with
+        | Leaf => true
+        | Node l o r =>
+          (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0
+      end.
+    Definition for_all m := xforall m 1.
+
+    Fixpoint xexists (m : t) (i : elt) :=
+      match m with
+        | Leaf => false
+        | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0
+      end.
+    Definition exists_ m := xexists m 1.
+
+    Fixpoint xfilter (m : t) (i : elt) : t :=
+      match m with
+        | Leaf => Leaf
+        | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1)
+      end.
+    Definition filter m := xfilter m 1.
+
+    Fixpoint xpartition (m : t) (i : elt) : t * t :=
+      match m with
+        | Leaf => (Leaf,Leaf)
+        | Node l o r =>
+          let (lt,lf) := xpartition l i~0 in
+          let (rt,rf) := xpartition r i~1 in
+             if o then
+               let fi := f (rev i) in
+                 (node lt fi rt, node lf (negb fi) rf)
+             else
+                 (node lt false rt, node lf false rf)
+      end.
+    Definition partition m := xpartition m 1.
+
+  End Quantifiers.
+
+  (** uses [a] to accumulate values rather than doing a lot of concatenations *)
+
+  Fixpoint xelements (m : t) (i : elt) (a: list elt) :=
+    match m with
+      | Leaf => a
+      | Node l false r => xelements l i~0 (xelements r i~1 a)
+      | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a)
+    end.
+
+  Definition elements (m : t) := xelements m 1 nil.
+
+  Fixpoint cardinal (m : t) : nat :=
+    match m with
+      | Leaf => O
+      | Node l false r => (cardinal l + cardinal r)%nat
+      | Node l true r => S (cardinal l + cardinal r)
+    end.
+
+  Definition omap (f: elt -> elt) x :=
+    match x with
+      | None => None
+      | Some i => Some (f i)
+    end.
+
+  (** would it be more efficient to use a path like in the above functions ? *)
+
+  Fixpoint choose (m: t) : option elt :=
+    match m with
+      | Leaf => None
+      | Node l o r => if o then Some 1 else
+        match choose l with
+          | None => omap xI (choose r)
+          | Some i => Some i~0
+        end
+    end.
+
+  Fixpoint min_elt (m: t) : option elt :=
+    match m with
+      | Leaf => None
+      | Node l o r =>
+        match min_elt l with
+          | None => if o then Some 1 else omap xI (min_elt r)
+          | Some i => Some i~0
+        end
+    end.
+
+  Fixpoint max_elt (m: t) : option elt :=
+    match m with
+      | Leaf => None
+      | Node l o r =>
+        match max_elt r with
+          | None => if o then Some 1 else omap xO (max_elt l)
+          | Some i => Some i~1
+        end
+    end.
+
+  (** lexicographic product, defined using a notation to keep things lazy *)
+
+  Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end.
+
+  Definition compare_bool a b :=
+    match a,b with
+      | false, true => Lt
+      | true, false => Gt
+      | _,_ => Eq
+    end.
+
+  Fixpoint compare_fun (m m': t): comparison :=
+    match m,m' with
+      | Leaf,_ => if is_empty m' then Eq else Lt
+      | _,Leaf => if is_empty m then Eq else Gt
+      | Node l o r,Node l' o' r' =>
+        lex (compare_bool o o') (lex (compare_fun l l') (compare_fun r r'))
+    end.
+
+
+  Definition In i t := mem i t = true.
+  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 := Equal.
+
+  Declare Equivalent Keys Equal eq.
+
+  Definition lt m m' := compare_fun m m' = Lt.
+
+  (** Specification of [In] *)
+
+  Lemma In_1: forall s x y, E.eq x y -> In x s -> In y s.
+  Proof. intros s x y ->. trivial. Qed.
+
+  (** Specification of [eq] *)
+
+  Lemma eq_refl: forall s, eq s s.
+  Proof. unfold eq, Equal. reflexivity. Qed.
+
+  Lemma eq_sym: forall s s', eq s s' -> eq s' s.
+  Proof. unfold eq, Equal. intros. symmetry. trivial. Qed.
+
+  Lemma eq_trans: forall s s' s'', eq s s' -> eq s' s'' -> eq s s''.
+  Proof. unfold eq, Equal. intros ? ? ? H ? ?. rewrite H. trivial. Qed.
+
+  (** Specification of [mem] *)
+
+  Lemma mem_1: forall s x, In x s -> mem x s = true.
+  Proof. unfold In. trivial. Qed.
+
+  Lemma mem_2: forall s x, mem x s = true -> In x s.
+  Proof. unfold In. trivial. Qed.
+
+  (** Additional lemmas for mem  *)
+
+  Lemma mem_Leaf: forall x, mem x Leaf = false.
+  Proof. destruct x; trivial. Qed.
+
+  (** Specification of [empty] *)
+
+  Lemma empty_1 : Empty empty.
+  Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed.
+
+  (** Specification of node  *)
+
+  Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r).
+  Proof.
+    intros x l o r.
+    case o; trivial.
+    destruct l; trivial.
+    destruct r; trivial.
+    now destruct x.
+  Qed.
+  Local Opaque node.
+
+  (** Specification of [is_empty] *)
+
+  Lemma is_empty_spec: forall s, Empty s <-> is_empty s = true.
+  Proof.
+    unfold Empty, In.
+    induction s as [|l IHl o r IHr]; simpl. now split.
+      rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear IHl IHr.
+      destruct o; simpl; split.
+        intro H. elim (H 1). reflexivity.
+        intuition discriminate.
+        intro H. split. split. reflexivity.
+          intro a. apply (H a~0).
+          intro a. apply (H a~1).
+        intros H [a|a|]; apply H || intro; discriminate.
+  Qed.
+
+  Lemma is_empty_1: forall s, Empty s -> is_empty s = true.
+  Proof. intro. rewrite is_empty_spec. trivial. Qed.
+
+  Lemma is_empty_2: forall s, is_empty s = true -> Empty s.
+  Proof. intro. rewrite is_empty_spec. trivial. Qed.
+
+  (** Specification of [subset] *)
+
+  Lemma subset_Leaf_s: forall s, Leaf [<=] s.
+  Proof. intros s i Hi. elim (empty_1 Hi). Qed.
+
+  Lemma subset_spec: forall s s', s [<=] s' <-> subset s s' = true.
+  Proof.
+    induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl.
+      split; intros. reflexivity. apply subset_Leaf_s.
+
+      split; intros. reflexivity. apply subset_Leaf_s.
+
+      rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- 2is_empty_spec.
+      destruct o; simpl.
+        split.
+          intro H. elim (@empty_1 1). apply H. reflexivity.
+          intuition discriminate.
+        split; intro H.
+          split. split. reflexivity.
+          unfold Empty. intros a H1. apply (@empty_1 (a~0)). apply H. assumption.
+          unfold Empty. intros a H1. apply (@empty_1 (a~1)). apply H. assumption.
+          destruct H as [[_ Hl] Hr].
+          intros [i|i|] Hi.
+            elim (Hr i Hi).
+            elim (Hl i Hi).
+            discriminate.
+
+      rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear.
+      destruct o; simpl.
+       split; intro H.
+         split. split.
+          destruct o'; trivial.
+          specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity.
+          intros i Hi. apply (H i~0). apply Hi.
+          intros i Hi. apply (H i~1). apply Hi.
+         destruct H as [[Ho' Hl] Hr]. rewrite Ho'.
+          intros i Hi. destruct i.
+            apply (Hr i). assumption.
+            apply (Hl i). assumption.
+            assumption.
+       split; intros.
+         split. split. reflexivity.
+           intros i Hi. apply (H i~0). apply Hi.
+           intros i Hi. apply (H i~1). apply Hi.
+           intros i Hi. destruct i; destruct H as [[H Hl] Hr].
+             apply (Hr i). assumption.
+             apply (Hl i). assumption.
+             discriminate Hi.
+  Qed.
+
+
+  Lemma subset_1: forall s s', Subset s s' -> subset s s' = true.
+  Proof. intros s s'. apply -> subset_spec; trivial. Qed.
+
+  Lemma subset_2: forall s s', subset s s' = true -> Subset s s'.
+  Proof. intros s s'. apply <- subset_spec; trivial. Qed.
+
+  (** Specification of [equal] (via subset) *)
+
+  Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s.
+  Proof.
+    induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial.
+      destruct o. reflexivity. rewrite andb_comm. reflexivity.
+      rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true.
+       rewrite 7andb_true_iff, eqb_true_iff.
+      rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst.
+       destruct o'; reflexivity.
+       destruct o'; reflexivity.
+       destruct o; auto. destruct o'; trivial.
+  Qed.
+
+  Lemma equal_spec: forall s s', Equal s s' <-> equal s s' = true.
+  Proof.
+    intros. rewrite equal_subset. rewrite andb_true_iff.
+    rewrite <- 2subset_spec. unfold Equal, Subset. firstorder.
+  Qed.
+
+  Lemma equal_1: forall s s', Equal s s' -> equal s s' = true.
+  Proof. intros s s'. apply -> equal_spec; trivial. Qed.
+
+  Lemma equal_2: forall s s', equal s s' = true -> Equal s s'.
+  Proof. intros s s'. apply <- equal_spec; trivial. Qed.
+
+  Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }.
+  Proof.
+    unfold eq.
+    intros. case_eq (equal s s'); intro H.
+     left. apply equal_2, H.
+     right. abstract (intro H'; rewrite (equal_1 H') in H; discriminate).
+  Defined.
+
+  (** (Specified) definition of [compare] *)
+
+  Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' ->
+    lex u v = CompOpp (lex u' v').
+  Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed.
+
+  Lemma compare_bool_inv: forall b b',
+    compare_bool b b' = CompOpp (compare_bool b' b).
+  Proof. intros [|] [|]; reflexivity. Qed.
+
+  Lemma compare_inv: forall s s', compare_fun s s' = CompOpp (compare_fun s' s).
+  Proof.
+    induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial.
+    unfold compare_fun. case is_empty; reflexivity.
+    unfold compare_fun. case is_empty; reflexivity.
+    simpl. rewrite compare_bool_inv.
+     case compare_bool; simpl; trivial; apply lex_Opp; auto.
+  Qed.
+
+  Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq.
+  Proof. intros u v; destruct u; intuition discriminate. Qed.
+
+  Lemma compare_bool_Eq: forall b1 b2,
+    compare_bool b1 b2 = Eq <-> eqb b1 b2 = true.
+  Proof. intros [|] [|]; intuition discriminate. Qed.
+
+  Lemma compare_equal: forall s s', compare_fun s s' = Eq <-> equal s s' = true.
+  Proof.
+    induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r'].
+     simpl. tauto.
+     unfold compare_fun, equal. case is_empty; intuition discriminate.
+     unfold compare_fun, equal. case is_empty; intuition discriminate.
+     simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff.
+     rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr.
+     rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity.
+  Qed.
+
+
+  Lemma compare_gt: forall s s', compare_fun s s' = Gt -> lt s' s.
+  Proof.
+    unfold lt. intros s s'. rewrite compare_inv.
+     case compare_fun; trivial; intros; discriminate.
+  Qed.
+
+  Lemma compare_eq: forall s s', compare_fun s s' = Eq -> eq s s'.
+  Proof.
+    unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial.
+  Qed.
+
+  Lemma compare : forall s s' : t, Compare lt eq s s'.
+  Proof.
+    intros. case_eq (compare_fun s s'); intro H.
+    apply EQ. apply compare_eq, H.
+    apply LT. assumption.
+    apply GT. apply compare_gt, H.
+  Defined.
+
+  Section lt_spec.
+
+  Inductive ct: comparison -> comparison -> comparison -> Prop :=
+  | ct_xxx: forall x, ct x  x  x
+  | ct_xex: forall x, ct x  Eq x
+  | ct_exx: forall x, ct Eq x  x
+  | ct_glx: forall x, ct Gt Lt x
+  | ct_lgx: forall x, ct Lt Gt x.
+
+  Lemma ct_cxe: forall x, ct (CompOpp x) x Eq.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_xce: forall x, ct x (CompOpp x) Eq.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_lxl: forall x, ct Lt x Lt.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_gxg: forall x, ct Gt x Gt.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_xll: forall x, ct x Lt Lt.
+  Proof. destruct x; constructor. Qed.
+
+  Lemma ct_xgg: forall x, ct x Gt Gt.
+  Proof. destruct x; constructor. Qed.
+
+  Local Hint Constructors ct: ct.
+  Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct.
+  Ltac ct := trivial with ct.
+
+  Lemma ct_lex: forall u v w u' v' w',
+    ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w').
+  Proof.
+    intros u v w u' v' w' H H'.
+    inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct.
+  Qed.
+
+  Lemma ct_compare_bool:
+    forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c).
+  Proof.
+    intros [|] [|] [|]; constructor.
+  Qed.
+
+  Lemma compare_x_Leaf: forall s,
+    compare_fun s Leaf = if is_empty s then Eq else Gt.
+  Proof.
+    intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity.
+  Qed.
+
+  Lemma compare_empty_x: forall a, is_empty a = true ->
+    forall b, compare_fun a b = if is_empty b then Eq else Lt.
+  Proof.
+    induction a as [|l IHl o r IHr]; trivial.
+    destruct o. intro; discriminate.
+    simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff.
+    intros [Hl Hr].
+    destruct b as [|l' [|] r']; simpl compare_fun; trivial.
+     rewrite Hl, Hr. trivial.
+     rewrite (IHl Hl), (IHr Hr). simpl.
+     case (is_empty l'); case (is_empty r'); trivial.
+  Qed.
+
+  Lemma compare_x_empty: forall a, is_empty a = true ->
+    forall b, compare_fun b a = if is_empty b then Eq else Gt.
+  Proof.
+    setoid_rewrite <- compare_x_Leaf.
+    intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity.
+  Qed.
+
+  Lemma ct_compare_fun:
+    forall a b c, ct (compare_fun a b) (compare_fun b c) (compare_fun a c).
+  Proof.
+    induction a as [|l IHl o r IHr]; intros s' s''.
+     destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct.
+      rewrite compare_inv. ct.
+      unfold compare_fun at 1. case_eq (is_empty (Node l' o' r')); intro H'.
+       rewrite (compare_empty_x _ H'). ct.
+       unfold compare_fun at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''.
+        rewrite (compare_x_empty _ H''), H'. ct.
+        ct.
+
+     destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r''].
+      ct.
+      unfold compare_fun at 2. rewrite compare_x_Leaf.
+      case_eq (is_empty (Node l o r)); intro H.
+       rewrite (compare_empty_x _ H). ct.
+       case_eq (is_empty (Node l'' o'' r'')); intro H''.
+        rewrite (compare_x_empty _ H''), H. ct.
+        ct.
+
+      rewrite 2 compare_x_Leaf.
+      case_eq (is_empty (Node l o r)); intro H.
+       rewrite compare_inv, (compare_x_empty _ H). ct.
+       case_eq (is_empty (Node l' o' r')); intro H'.
+        rewrite (compare_x_empty _ H'), H. ct.
+        ct.
+
+      simpl compare_fun. apply ct_lex. apply ct_compare_bool.
+       apply ct_lex; trivial.
+  Qed.
+
+  End lt_spec.
+
+  Lemma lt_trans: forall s s' s'', lt s s' -> lt s' s'' -> lt s s''.
+  Proof.
+    unfold lt. intros a b c. assert (H := ct_compare_fun a b c).
+    inversion_clear H; trivial; intros; discriminate.
+  Qed.
+
+  Lemma lt_not_eq: forall s s', lt s s' -> ~ eq s s'.
+  Proof.
+    unfold lt, eq. intros s s' H H'.
+     rewrite equal_spec, <- compare_equal in H'. congruence.
+  Qed.
+
+  (** Specification of [add] *)
+
+  Lemma add_spec: forall x y s, In y (add x s) <-> x=y \/ In y s.
+  Proof.
+    unfold In. induction x; intros [y|y|] [|l o r]; simpl mem;
+    try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence.
+  Qed.
+
+  Lemma add_1: forall s x y, x = y -> In y (add x s).
+  Proof. intros. apply <- add_spec. left. assumption. Qed.
+
+  Lemma add_2: forall s x y, In y s -> In y (add x s).
+  Proof. intros. apply <- add_spec. right. assumption. Qed.
+
+  Lemma add_3: forall s x y, x<>y -> In y (add x s) -> In y s.
+  Proof.
+    intros s x y H. rewrite add_spec. intros [->|?]; trivial. elim H; trivial.
+  Qed.
+
+  (** Specification of [remove] *)
+
+  Lemma remove_spec: forall x y s, In y (remove x s) <-> x<>y /\ In y s.
+  Proof.
+    unfold In.
+    induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node;
+     simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf;
+     intuition congruence.
+  Qed.
+
+  Lemma remove_1: forall s x y, x=y -> ~ In y (remove x s).
+  Proof. intros. rewrite remove_spec. tauto. Qed.
+
+  Lemma remove_2: forall s x y, x<>y -> In y s -> In y (remove x s).
+  Proof. intros. rewrite remove_spec. split; assumption. Qed.
+
+  Lemma remove_3: forall s x y, In y (remove x s) -> In y s.
+  Proof. intros s x y. rewrite remove_spec. tauto. Qed.
+
+  (** Specification of [singleton] *)
+
+  Lemma singleton_1: forall x y, In y (singleton x) -> x=y.
+  Proof.
+    unfold singleton. intros x y. rewrite add_spec.
+    unfold In. rewrite mem_Leaf. intuition discriminate.
+  Qed.
+
+  Lemma singleton_2: forall x y, x = y -> In y (singleton x).
+  Proof.
+    unfold singleton. intros. apply add_1. assumption.
+  Qed.
+
+  (** Specification of [union] *)
+
+  Lemma union_spec: forall x s s', In x (union s s') <-> In x s \/ In x s'.
+  Proof.
+    unfold In.
+    induction x; destruct s; destruct s'; simpl union; simpl mem;
+      try (rewrite IHx; clear IHx); try intuition congruence.
+      apply orb_true_iff.
+  Qed.
+
+  Lemma union_1: forall s s' x, In x (union s s') -> In x s \/ In x s'.
+  Proof. intros. apply -> union_spec. assumption. Qed.
+
+  Lemma union_2: forall s s' x, In x s -> In x (union s s').
+  Proof. intros. apply <- union_spec. left. assumption. Qed.
+
+  Lemma union_3: forall s s' x, In x s' -> In x (union s s').
+  Proof. intros. apply <- union_spec. right. assumption. Qed.
+
+  (** Specification of [inter] *)
+
+  Lemma inter_spec: forall x s s', In x (inter s s') <-> In x s /\ In x s'.
+  Proof.
+    unfold In.
+    induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node;
+     simpl mem; try (rewrite IHx; clear IHx); try intuition congruence.
+     apply andb_true_iff.
+  Qed.
+
+  Lemma inter_1: forall s s' x, In x (inter s s') -> In x s.
+  Proof. intros s s' x. rewrite inter_spec. tauto. Qed.
+
+  Lemma inter_2: forall s s' x, In x (inter s s') -> In x s'.
+  Proof. intros s s' x. rewrite inter_spec. tauto. Qed.
+
+  Lemma inter_3: forall s s' x, In x s -> In x s' -> In x (inter s s').
+  Proof. intros. rewrite inter_spec. split; assumption. Qed.
+
+  (** Specification of [diff] *)
+
+  Lemma diff_spec: forall x s s', In x (diff s s') <-> In x s /\ ~ In x s'.
+  Proof.
+    unfold In.
+    induction x; destruct s; destruct s' as [|l' o' r']; simpl diff;
+     rewrite ?mem_node; simpl mem;
+      try (rewrite IHx; clear IHx); try intuition congruence.
+      rewrite andb_true_iff. destruct o'; intuition discriminate.
+  Qed.
+
+  Lemma diff_1: forall s s' x, In x (diff s s') -> In x s.
+  Proof. intros s s' x. rewrite diff_spec. tauto. Qed.
+
+  Lemma diff_2: forall s s' x, In x (diff s s') -> ~ In x s'.
+  Proof. intros s s' x. rewrite diff_spec. tauto. Qed.
+
+  Lemma diff_3: forall s s' x, In x s -> ~ In x s' -> In x (diff s s').
+  Proof. intros. rewrite diff_spec. split; assumption. Qed.
+
+  (** Specification of [fold] *)
+  
+  Lemma fold_1: forall s (A : Type) (i : A) (f : elt -> A -> A),
+      fold f s i = fold_left (fun a e => f e a) (elements s) i.
+  Proof.
+    unfold fold, elements. intros s A i f. revert s i.
+    set (f' := fun a e => f e a).
+    assert (H: forall s i j acc,
+      fold_left f' acc (xfold f s i j) =
+      fold_left f' (xelements s j acc) i).
+
+    induction s as [|l IHl o r IHr]; intros; trivial.
+      destruct o; simpl xelements; simpl xfold.
+        rewrite IHr, <- IHl. reflexivity.
+        rewrite IHr. apply IHl.
+
+    intros. exact (H s i 1 nil).
+  Qed.
+
+  (** Specification of [cardinal] *)
+
+  Lemma cardinal_1: forall s, cardinal s = length (elements s).
+  Proof.
+    unfold elements.
+    assert (H: forall s j acc,
+                (cardinal s + length acc)%nat = length (xelements s j acc)).
+
+    induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b.
+      rewrite <- IHl. simpl. rewrite <- IHr.
+       rewrite <- plus_n_Sm, Plus.plus_assoc. reflexivity.
+      rewrite <- IHl, <- IHr. rewrite Plus.plus_assoc. reflexivity.
+
+    intros. rewrite <- H. simpl. rewrite Plus.plus_comm. reflexivity.
+  Qed.
+
+  (** Specification of [filter] *)
+
+  Lemma xfilter_spec: forall f s x i,
+    In x (xfilter f s i) <-> In x s /\ f (i@x) = true.
+  Proof.
+    intro f. unfold In.
+    induction s as [|l IHl o r IHr]; intros x i; simpl xfilter.
+     rewrite mem_Leaf. intuition discriminate.
+     rewrite mem_node. destruct x; simpl.
+       rewrite IHr. reflexivity.
+       rewrite IHl. reflexivity.
+       rewrite <- andb_lazy_alt. apply andb_true_iff.
+  Qed.
+
+  Lemma filter_1 : forall s x f, @compat_bool elt E.eq f ->
+    In x (filter f s) -> In x s.
+  Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed.
+
+  Lemma filter_2 : forall s x f, @compat_bool elt E.eq f ->
+    In x (filter f s) -> f x = true.
+  Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed.
+
+  Lemma filter_3 : forall s x f, @compat_bool elt E.eq f -> In x s ->
+    f x = true -> In x (filter f s).
+  Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed.
+
+
+  (** Specification of [for_all] *)
+
+  Lemma xforall_spec: forall f s i,
+    xforall f s i = true <-> For_all (fun x => f (i@x) = true) s.
+  Proof.
+    unfold For_all, In. intro f.
+    induction s as [|l IHl o r IHr]; intros i; simpl. now split.
+     rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff.
+     rewrite IHl, IHr. clear IHl IHr.
+      split.
+       intros [[Hi Hr] Hl] x. destruct x; simpl; intro H.
+        apply Hr, H.
+        apply Hl, H.
+        rewrite H in Hi. assumption.
+       intro H; intuition.
+        specialize (H 1). destruct o. apply H. reflexivity. reflexivity.
+        apply H. assumption.
+        apply H. assumption.
+  Qed.
+
+  Lemma for_all_1 : forall s f, @compat_bool elt E.eq f ->
+    For_all (fun x => f x = true) s -> for_all f s = true.
+  Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed.
+
+  Lemma for_all_2 : forall s f, @compat_bool elt E.eq f ->
+    for_all f s = true -> For_all (fun x => f x = true) s.
+  Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed.
+
+
+  (** Specification of [exists] *)
+
+  Lemma xexists_spec: forall f s i,
+    xexists f s i = true <-> Exists (fun x => f (i@x) = true) s.
+  Proof.
+    unfold Exists, In. intro f.
+    induction s as [|l IHl o r IHr]; intros i; simpl.
+    split; [ discriminate | now intros  [ _ [? _]]].
+     rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff.
+     rewrite IHl, IHr. clear IHl IHr.
+      split.
+       intros [[Hi|[x Hr]]|[x Hl]].
+        exists 1. exact Hi.
+        exists x~1. exact Hr.
+        exists x~0. exact Hl.
+       intros [[x|x|] H]; eauto.
+  Qed.
+
+  Lemma exists_1 : forall s f, @compat_bool elt E.eq f ->
+      Exists (fun x => f x = true) s -> exists_ f s = true.
+  Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed.
+
+  Lemma exists_2 : forall s f, @compat_bool elt E.eq f ->
+      exists_ f s = true -> Exists (fun x => f x = true) s.
+  Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed.
+
+
+  (** Specification of [partition] *)
+
+  Lemma partition_filter : forall s f,
+    partition f s = (filter f s, filter (fun x => negb (f x)) s).
+  Proof.
+    unfold partition, filter. intros s f. generalize 1 as j.
+    induction s as [|l IHl o r IHr]; intro j.
+      reflexivity.
+      destruct o; simpl; rewrite IHl, IHr; reflexivity.
+  Qed.
+
+  Lemma partition_1 : forall s f, @compat_bool elt E.eq f ->
+      Equal (fst (partition f s)) (filter f s).
+  Proof. intros. rewrite partition_filter. apply eq_refl. Qed.
+
+  Lemma partition_2 : forall s f, @compat_bool elt E.eq f ->
+      Equal (snd (partition f s)) (filter (fun x => negb (f x)) s).
+  Proof. intros. rewrite partition_filter. apply eq_refl. Qed.
+
+
+  (** Specification of [elements] *)
+
+  Notation InL := (InA E.eq).
+
+  Lemma xelements_spec: forall s j acc y,
+    InL y (xelements s j acc)
+    <->
+    InL y acc \/ exists x, y=(j@x) /\ mem x s = true.
+  Proof.
+    induction s as [|l IHl o r IHr]; simpl.
+      intros. split; intro H.
+        left. assumption.
+        destruct H as [H|[x [Hx Hx']]]. assumption. discriminate.
+
+      intros j acc y. case o.
+        rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split.
+          intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto.
+            right. exists x~1. auto.
+            right. exists x~0. auto.
+          intros [H|[x [-> H]]].
+            eauto.
+            destruct x.
+              left. right. right. exists x; auto.
+              right. exists x; auto.
+              left. left. reflexivity.
+
+        rewrite IHl, IHr. clear IHl IHr. split.
+          intros [[H|[x [-> H]]]|[x [-> H]]].
+            eauto.
+            right. exists x~1. auto.
+            right. exists x~0. auto.
+          intros [H|[x [-> H]]].
+            eauto.
+            destruct x.
+              left. right.  exists x; auto.
+              right. exists x; auto.
+              discriminate.
+  Qed.
+
+  Lemma elements_1: forall s x, In x s -> InL x (elements s).
+  Proof.
+    unfold elements, In. intros.
+    rewrite xelements_spec. right. exists x. auto.
+  Qed.
+
+  Lemma elements_2: forall s x, InL x (elements s) -> In x s.
+  Proof.
+    unfold elements, In. intros s x H.
+    rewrite xelements_spec in H. destruct H as [H|[y [H H']]].
+      inversion_clear H.
+      rewrite H. assumption.
+  Qed.
+
+  Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y).
+  Proof. induction j; intros; simpl; auto. Qed.
+
+  Lemma elements_3: forall s, sort E.lt (elements s).
+  Proof.
+    unfold elements.
+    assert (H: forall s j acc,
+      sort E.lt acc ->
+      (forall x y, In x s ->  InL y acc -> E.lt (j@x) y) ->
+      sort E.lt (xelements s j acc)).
+
+    induction s as [|l IHl o r IHr]; simpl; trivial.
+    intros j acc Hacc Hsacc. destruct o.
+      apply IHl. constructor.
+       apply IHr. apply Hacc.
+       intros x y Hx Hy. apply Hsacc; assumption.
+       case_eq (xelements r j~1 acc). constructor.
+       intros z q H. constructor.
+       assert (H': InL z (xelements r j~1 acc)).
+        rewrite H. constructor. reflexivity.
+       clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]].
+         apply (Hsacc 1 z); trivial. reflexivity.
+         simpl. apply lt_rev_append. exact I.
+       intros x y Hx Hy. inversion_clear Hy.
+         rewrite H. simpl. apply lt_rev_append. exact I.
+         rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]].
+           apply Hsacc; assumption.
+           simpl. apply lt_rev_append. exact I.
+
+      apply IHl. apply IHr. apply Hacc.
+       intros x y Hx Hy. apply Hsacc; assumption.
+       intros x y Hx Hy. rewrite xelements_spec in Hy.
+        destruct Hy as [Hy|[z [-> Hy]]].
+         apply Hsacc; assumption.
+         simpl. apply lt_rev_append. exact I.
+
+    intros. apply H. constructor.
+      intros x y _ H'. inversion H'.
+  Qed.
+
+  Lemma elements_3w: forall s, NoDupA E.eq (elements s).
+  Proof.
+    intro. apply SortA_NoDupA with E.lt.
+      constructor.
+       intro. apply E.eq_refl.
+       intro. apply E.eq_sym.
+       intro. apply E.eq_trans.
+      constructor.
+       intros x H. apply E.lt_not_eq in H. apply H. reflexivity.
+       intro. apply E.lt_trans.
+     solve_proper.
+      apply elements_3.
+  Qed.
+
+
+  (** Specification of [choose] *)
+
+  Lemma choose_1: forall s x, choose s = Some x -> In x s.
+  Proof.
+    induction s as [| l IHl o r IHr]; simpl.
+      intros. discriminate.
+      destruct o.
+        intros x H. injection H; intros; subst. reflexivity.
+        revert IHl. case choose.
+          intros p Hp x H. injection H as <-. apply Hp.
+           reflexivity.
+          intros _ x. revert IHr. case choose.
+            intros p Hp H. injection H as <-. apply Hp.
+            reflexivity.
+            intros. discriminate.
+  Qed.
+
+  Lemma choose_2: forall s, choose s = None -> Empty s.
+  Proof.
+    unfold Empty, In. intros s H.
+    induction s as [|l IHl o r IHr].
+      intro. apply empty_1.
+      destruct o.
+        discriminate.
+        simpl in H. destruct (choose l).
+          discriminate.
+          destruct (choose r).
+            discriminate.
+            intros [a|a|].
+              apply IHr. reflexivity.
+              apply IHl. reflexivity.
+              discriminate.
+  Qed.
+
+  Lemma choose_empty: forall s, is_empty s = true -> choose s = None.
+  Proof.
+    intros s Hs. case_eq (choose s); trivial.
+    intros p Hp. apply choose_1 in Hp. apply is_empty_2 in Hs. elim (Hs _ Hp).
+  Qed.
+
+  Lemma choose_3': forall s s', Equal s s' -> choose s = choose s'.
+  Proof.
+    setoid_rewrite equal_spec.
+    induction s as [|l IHl o r IHr].
+      intros. symmetry. apply choose_empty. assumption.
+
+      destruct s' as [|l' o' r'].
+        generalize (Node l o r) as s. simpl. intros. apply choose_empty.
+        rewrite <- equal_spec in H. apply eq_sym in H. rewrite equal_spec in H.
+        assumption.
+
+        simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff.
+        intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity.
+  Qed.
+
+  Lemma choose_3: forall s s' x y,
+    choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y.
+  Proof. intros s s' x y Hx Hy H. apply choose_3' in H. congruence. Qed.
+
+
+  (** Specification of [min_elt] *)
+
+  Lemma min_elt_1: forall s x, min_elt s = Some x -> In x s.
+  Proof.
+   unfold In.
+   induction s as [| l IHl o r IHr]; simpl.
+     intros. discriminate.
+     intros x. destruct (min_elt l); intros.
+       injection H as <-. apply IHl. reflexivity.
+       destruct o; simpl.
+         injection H as <-. reflexivity.
+         destruct (min_elt r); simpl in *.
+           injection H as <-. apply IHr. reflexivity.
+           discriminate.
+  Qed.
+
+  Lemma min_elt_3: forall s, min_elt s = None -> Empty s.
+  Proof.
+    unfold Empty, In. intros s H.
+    induction s as [|l IHl o r IHr].
+      intro. apply empty_1.
+      intros [a|a|].
+        apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial.
+          case min_elt; intros; try discriminate. destruct o; discriminate.
+        apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial.
+         intro; discriminate.
+        revert H. clear. simpl. case min_elt; intros; try discriminate.
+         destruct o; discriminate.
+  Qed.
+
+  Lemma min_elt_2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x.
+  Proof.
+    unfold In.
+    induction s as [|l IHl o r IHr]; intros x y H H'.
+      discriminate.
+      simpl in H. case_eq (min_elt l).
+        intros p Hp. rewrite Hp in H. injection H as <-.
+        destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial.
+        intro Hp; rewrite Hp in H. apply min_elt_3 in Hp.
+        destruct o.
+          injection H as <-. intros Hl.
+          destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').
+
+          destruct (min_elt r).
+            injection H as <-.
+            destruct y as [z|z|].
+              apply (IHr e z); trivial.
+              elim (Hp _ H').
+              discriminate.
+            discriminate.
+  Qed.
+
+
+  (** Specification of [max_elt] *)
+
+  Lemma max_elt_1: forall s x, max_elt s = Some x -> In x s.
+  Proof.
+   unfold In.
+   induction s as [| l IHl o r IHr]; simpl.
+     intros. discriminate.
+     intros x. destruct (max_elt r); intros.
+       injection H as <-. apply IHr. reflexivity.
+       destruct o; simpl.
+         injection H as <-. reflexivity.
+         destruct (max_elt l); simpl in *.
+           injection H as <-. apply IHl. reflexivity.
+           discriminate.
+  Qed.
+
+  Lemma max_elt_3: forall s, max_elt s = None -> Empty s.
+  Proof.
+    unfold Empty, In. intros s H.
+    induction s as [|l IHl o r IHr].
+      intro. apply empty_1.
+      intros [a|a|].
+        apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial.
+         intro; discriminate.
+        apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial.
+          case max_elt; intros; try discriminate. destruct o; discriminate.
+        revert H. clear. simpl. case max_elt; intros; try discriminate.
+         destruct o; discriminate.
+  Qed.
+
+  Lemma max_elt_2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y.
+  Proof.
+    unfold In.
+    induction s as [|l IHl o r IHr]; intros x y H H'.
+      discriminate.
+      simpl in H. case_eq (max_elt r).
+        intros p Hp. rewrite Hp in H. injection H as <-.
+        destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial.
+        intro Hp; rewrite Hp in H. apply max_elt_3 in Hp.
+        destruct o.
+          injection H as <-. intros Hl.
+          destruct y as [z|z|]; simpl; trivial. elim (Hp _ H').
+
+          destruct (max_elt l).
+            injection H as <-.
+            destruct y as [z|z|].
+              elim (Hp _ H').
+              apply (IHl e z); trivial.
+              discriminate.
+            discriminate.
+  Qed.
+
+End PositiveSet.
diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v
new file mode 100644
index 0000000000..6b6546f82d
--- /dev/null
+++ b/theories/FSets/FSetProperties.v
@@ -0,0 +1,1171 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * Finite sets library *)
+
+(** This functor derives additional properties from [FSetInterface.S].
+    Contrary to the functor in [FSetEqProperties] it uses
+    predicates over sets instead of sets operations, i.e.
+    [In x s] instead of [mem x s=true],
+    [Equal s s'] instead of [equal s s'=true], etc. *)
+
+Require Export FSetInterface.
+Require Import DecidableTypeEx FSetFacts FSetDecide.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Hint Unfold transpose compat_op Proper respectful : fset.
+Hint Extern 1 (Equivalence _) => constructor; congruence : fset.
+
+(** First, a functor for Weak Sets in functorial version. *)
+
+Module WProperties_fun (Import E : DecidableType)(M : WSfun E).
+  Module Import Dec := WDecide_fun E M.
+  Module Import FM := Dec.F (* FSetFacts.WFacts_fun 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.
+
+  (** Alternative specification via [fold_right] *)
+
+  Lemma fold_spec_right (s:t)(A:Type)(i:A)(f : elt -> A -> A) :
+    fold f s i = List.fold_right f i (rev (elements s)).
+  Proof.
+   rewrite fold_1. symmetry. apply fold_left_rev_right.
+  Qed.
+
+  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_spec_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.
+  rewrite 2 fold_spec_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 [FSets] was first designed, the order in which Ocaml's [Set.fold]
+      takes the set elements was unspecified. This specification reflects
+      this fact:
+  *)
+
+  Lemma fold_0 :
+      forall s (A : 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.
+  apply fold_spec_right.
+  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),
+   compat_op E.eq eqA f ->
+   transpose eqA f ->
+   ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
+  Proof.
+  intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2)));
+    destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))).
+  rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2.
+  apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto 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 M.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:compat_op E.eq 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 with *.
+  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 with *.
+  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 M.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 fset.
+  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 with fset.
+  Qed.
+
+  (** ** Cardinal and (non-)emptiness *)
+
+  Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0.
+  Proof.
+  intros.
+  rewrite elements_Empty, M.cardinal_1.
+  destruct (elements s); intuition; discriminate.
+  Qed.
+
+  Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s.
+  Proof.
+  intros; rewrite cardinal_Empty; auto.
+  Qed.
+  Hint Resolve cardinal_inv_1 : fset.
+
+  Lemma cardinal_inv_2 :
+   forall s n, cardinal s = S n -> { x : elt | In x s }.
+  Proof.
+  intros; rewrite M.cardinal_1 in H.
+  generalize (elements_2 (s:=s)).
+  destruct (elements s); try discriminate.
+  exists e; auto.
+  Qed.
+
+  Lemma 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 with fset.
+  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 with signature (Equal ==> Logic.eq) as cardinal_m.
+  Proof.
+  exact Equal_cardinal.
+  Qed.
+
+  Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : fset.
+
+  (** ** Cardinal and set operators *)
+
+  Lemma empty_cardinal : cardinal empty = 0.
+  Proof.
+  rewrite cardinal_fold; apply fold_1; auto with set fset.
+  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 fset.
+  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 with fset.
+  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 Logic.eq_refl 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 fset.
+  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 fset.
+  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 fset.
+  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 fset.
+  Qed.
+
+  Lemma remove_cardinal_2 :
+   forall s x, ~In x s -> cardinal (remove x s) = cardinal s.
+  Proof.
+  auto with set fset.
+  Qed.
+
+  Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : fset.
+
+End WProperties_fun.
+
+(** 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:WS) := WProperties_fun M.E M.
+Module Properties := WProperties.
+
+
+(** Now comes some properties specific to the element ordering,
+    invalid for Weak Sets. *)
+
+Module OrdProperties (M:S).
+  Module ME:=OrderedTypeFacts(M.E).
+  Module Import P := Properties M.
+  Import FM.
+  Import M.E.
+  Import M.
+
+  (** First, a specialized version of SortA_equivlistA_eqlistA: *)
+  Lemma sort_equivlistA_eqlistA : forall l l' : list elt,
+   sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'.
+  Proof.
+  apply SortA_equivlistA_eqlistA; eauto 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; destruct (E.compare x y); intuition; try discriminate; ME.order.
+  Qed.
+
+  Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x.
+  Proof.
+   intros; unfold leb, gtb; destruct (E.compare x y); intuition; try discriminate; ME.order.
+  Qed.
+
+  Lemma gtb_compat : forall x, 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 : fset.
+
+  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 _ E.lt); auto with *.
+  intros.
+  rewrite gtb_1 in H.
+  assert (~E.lt y x).
+   unfold gtb in *; destruct (E.compare x y); intuition;
+   try discriminate; ME.order.
+  ME.order.
+  Qed.
+
+  Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' ->
+    eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s).
+  Proof.
+  intros; unfold elements_ge, elements_lt.
+  apply sort_equivlistA_eqlistA; auto with set.
+  apply (@SortA_app _ E.eq); auto with *.
+  apply (@filter_sort _ E.eq); auto with *.
+  constructor; auto.
+  apply (@filter_sort _ E.eq); auto 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.
+  destruct (E.compare a x); intuition.
+  fold (~E.lt a x); auto with *.
+  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 *.
+  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 by auto with *.
+  do 2 rewrite <- elements_iff; rewrite (H0 a); intuition.
+  Qed.
+
+  Lemma elements_Add_Below : forall s s' x,
+   Below x s -> Add x s s' ->
+     eqlistA E.eq (elements s') (x::elements s).
+  Proof.
+  intros.
+  apply sort_equivlistA_eqlistA; auto with *.
+  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.
+  do 2 rewrite <- elements_iff; rewrite (H0 a); intuition.
+  Qed.
+
+  (** Two other induction principles on sets: we can be more restrictive
+      on the element we add at each step.  *)
+
+  Lemma set_induction_max :
+   forall P : t -> Type,
+   (forall s : t, Empty s -> P s) ->
+   (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') ->
+   forall s : t, P s.
+  Proof.
+  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto with fset.
+  case_eq (max_elt s); intros.
+  apply X0 with (remove e s) e; auto with set.
+  apply IHn.
+  assert (S n = S (cardinal (remove e s))).
+   rewrite Heqn; apply cardinal_2 with e; auto with set.
+  inversion H0; auto.
+  red; intros.
+  rewrite remove_iff in H0; destruct H0.
+  generalize (@max_elt_2 s e y H H0); ME.order.
+
+  assert (H0:=max_elt_3 H).
+  rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn.
+  Qed.
+
+  Lemma set_induction_min :
+   forall P : t -> Type,
+   (forall s : t, Empty s -> P s) ->
+   (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') ->
+   forall s : t, P s.
+  Proof.
+  intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto with fset.
+  case_eq (min_elt s); intros.
+  apply X0 with (remove e s) e; auto with set.
+  apply IHn.
+  assert (S n = S (cardinal (remove e s))).
+   rewrite Heqn; apply cardinal_2 with e; auto with set.
+  inversion H0; auto.
+  red; intros.
+  rewrite remove_iff in H0; destruct H0.
+  generalize (@min_elt_2 s e y H H0); ME.order.
+
+  assert (H0:=min_elt_3 H).
+  rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn.
+  Qed.
+
+  (** More properties of [fold] : behavior with respect to Above/Below *)
+
+  Lemma fold_3 :
+   forall s s' x (A : Type) (eqA : A -> A -> Prop)
+     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
+   compat_op E.eq eqA f ->
+   Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)).
+  Proof.
+  intros.
+  rewrite 2 fold_spec_right.
+  change (f x (fold_right f i (rev (elements s)))) with
+    (fold_right f i (rev (x::nil)++rev (elements s))).
+  apply (@fold_right_eqlistA E.t E.eq A eqA st); auto.
+  rewrite <- distr_rev.
+  apply eqlistA_rev.
+  apply elements_Add_Above; auto.
+  Qed.
+
+  Lemma fold_4 :
+   forall s s' x (A : Type) (eqA : A -> A -> Prop)
+     (st : Equivalence eqA) (i : A) (f : elt -> A -> A),
+   compat_op E.eq eqA f ->
+   Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)).
+  Proof.
+  intros.
+  rewrite 2 M.fold_1.
+  set (g:=fun (a : A) (e : elt) => f e a).
+  change (eqA (fold_left g (elements s') i) (fold_left g (x::elements s) i)).
+  unfold g.
+  rewrite <- 2 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:compat_op E.eq eqA f).
+
+  Lemma fold_equal :
+   forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i).
+  Proof.
+  intros. rewrite 2 fold_spec_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_1 s)(@choose_2 s)
+             (@choose_1 s')(@choose_2 s')(@choose_3 s s');
+  destruct (choose s); destruct (choose s'); simpl; intuition.
+  apply H5 with e; rewrite <-H; auto.
+  apply H5 with e; rewrite H; auto.
+  Qed.
+
+End OrdProperties.
diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v
new file mode 100644
index 0000000000..f8d13ed2ba
--- /dev/null
+++ b/theories/FSets/FSetToFiniteSet.v
@@ -0,0 +1,158 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * Finite sets library : conversion to old [Finite_sets] *)
+
+Require Import Ensembles Finite_sets.
+Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx.
+
+(** * Going from [FSets] 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 FSet
+     ... at least in Prop. *)
+
+ Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e ->
+   exists s:M.t, !!s === e.
+ Proof.
+ induction 1.
+ exists M.empty.
+ apply empty_Empty_Set.
+ destruct IHFinite as (s,Hs).
+ exists (M.add x s).
+ apply Extensionality_Ensembles in Hs.
+ rewrite <- Hs.
+ apply add_Add.
+ Qed.
+
+End WS_to_Finite_set.
+
+
+Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U) :=
+  WS_to_Finite_set U M.
+
+
diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v
new file mode 100644
index 0000000000..1dacd05681
--- /dev/null
+++ b/theories/FSets/FSetWeakList.v
@@ -0,0 +1,30 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+(** * Finite sets library *)
+
+(** This file proposes an implementation of the non-dependent
+    interface [FSetInterface.WS] using lists without redundancy. *)
+
+Require Import FSetInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+(** This is just a compatibility layer, the real implementation
+    is now in [MSetWeakList] *)
+
+Require Equalities FSetCompat MSetWeakList.
+
+Module Make (X: DecidableType) <: WS with Module E := X.
+ Module E := X.
+ Module X' := Equalities.Update_DT X.
+ Module MSet := MSetWeakList.Make X'.
+ Include FSetCompat.Backport_WSets X MSet.
+End Make.
diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v
new file mode 100644
index 0000000000..7e9e7aae7e
--- /dev/null
+++ b/theories/FSets/FSets.v
@@ -0,0 +1,25 @@
+(************************************************************************)
+(*         *   The Coq Proof Assistant / The Coq Development Team       *)
+(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
+(* <O___,, *       (see CREDITS file for the list of authors)           *)
+(*   \VV/  **************************************************************)
+(*    //   *    This file is distributed under the terms of the         *)
+(*         *     GNU Lesser General Public License Version 2.1          *)
+(*         *     (see LICENSE file for the text of the license)         *)
+(************************************************************************)
+
+Require Export OrderedType.
+Require Export OrderedTypeEx.
+Require Export OrderedTypeAlt.
+Require Export DecidableType.
+Require Export DecidableTypeEx.
+Require Export FSetInterface.
+Require Export FSetBridge.
+Require Export FSetFacts.
+Require Export FSetDecide.
+Require Export FSetProperties.
+Require Export FSetEqProperties.
+Require Export FSetWeakList.
+Require Export FSetList.
+Require Export FSetPositive.
+Require Export FSetAVL.