summaryrefslogtreecommitdiff
path: root/theories
diff options
context:
space:
mode:
Diffstat (limited to 'theories')
-rw-r--r--theories/Classes/CMorphisms.v24
-rw-r--r--theories/Init/Logic.v3
-rw-r--r--theories/Init/Notations.v2
-rw-r--r--theories/Init/Prelude.v2
-rw-r--r--theories/Init/Tactics.v14
-rw-r--r--theories/Lists/List.v10
-rw-r--r--theories/Lists/SetoidList.v11
-rw-r--r--theories/Lists/SetoidPermutation.v74
-rw-r--r--theories/MMaps/MMapAVL.v2158
-rw-r--r--theories/MMaps/MMapFacts.v2434
-rw-r--r--theories/MMaps/MMapInterface.v292
-rw-r--r--theories/MMaps/MMapList.v1144
-rw-r--r--theories/MMaps/MMapPositive.v698
-rw-r--r--theories/MMaps/MMapWeakList.v687
-rw-r--r--theories/MMaps/MMaps.v16
-rw-r--r--theories/MMaps/vo.itarget7
-rw-r--r--theories/MSets/MSetAVL.v18
-rw-r--r--theories/MSets/MSetPositive.v81
-rw-r--r--theories/Program/Equality.v11
-rw-r--r--theories/Program/Utils.v2
-rw-r--r--theories/Reals/Alembert.v1
-rw-r--r--theories/Reals/Cos_rel.v7
-rw-r--r--theories/Reals/PSeries_reg.v6
-rw-r--r--theories/Reals/Ratan.v10
-rw-r--r--theories/Structures/EqualitiesFacts.v216
-rw-r--r--theories/Structures/OrdersEx.v67
-rw-r--r--theories/Structures/OrdersLists.v211
-rw-r--r--theories/ZArith/Int.v193
-rw-r--r--theories/theories.itarget1
29 files changed, 7972 insertions, 428 deletions
diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v
index 073cd5e9..048faa91 100644
--- a/theories/Classes/CMorphisms.v
+++ b/theories/Classes/CMorphisms.v
@@ -31,7 +31,7 @@ Set Universe Polymorphism.
The relation [R] will be instantiated by [respectful] and [A] by an arrow
type for usual morphisms. *)
Section Proper.
- Context {A B : Type}.
+ Context {A : Type}.
Class Proper (R : crelation A) (m : A) :=
proper_prf : R m m.
@@ -71,7 +71,7 @@ Section Proper.
(** The non-dependent version is an instance where we forget dependencies. *)
- Definition respectful (R : crelation A) (R' : crelation B) : crelation (A -> B) :=
+ Definition respectful {B} (R : crelation A) (R' : crelation B) : crelation (A -> B) :=
Eval compute in @respectful_hetero A A (fun _ => B) (fun _ => B) R (fun _ _ => R').
End Proper.
@@ -143,7 +143,7 @@ Ltac f_equiv :=
end.
Section Relations.
- Context {A B : Type}.
+ Context {A : Type}.
(** [forall_def] reifies the dependent product as a definition. *)
@@ -156,10 +156,10 @@ Section Relations.
fun f g => forall a, sig a (f a) (g a).
(** Non-dependent pointwise lifting *)
- Definition pointwise_relation (R : crelation B) : crelation (A -> B) :=
+ Definition pointwise_relation {B} (R : crelation B) : crelation (A -> B) :=
fun f g => forall a, R (f a) (g a).
- Lemma pointwise_pointwise (R : crelation B) :
+ Lemma pointwise_pointwise {B} (R : crelation B) :
relation_equivalence (pointwise_relation R) (@eq A ==> R).
Proof. intros. split. simpl_crelation. firstorder. Qed.
@@ -252,7 +252,7 @@ Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)
Section GenericInstances.
(* Share universes *)
- Context {A B C : Type}.
+ Implicit Types A B C : Type.
(** We can build a PER on the Coq function space if we have PERs on the domain and
codomain. *)
@@ -379,7 +379,7 @@ Section GenericInstances.
Lemma symmetric_equiv_flip `(Symmetric A R) : relation_equivalence R (flip R).
Proof. firstorder. Qed.
- Global Program Instance compose_proper RA RB RC :
+ Global Program Instance compose_proper A B C RA RB RC :
Proper ((RB ==> RC) ==> (RA ==> RB) ==> (RA ==> RC)) (@compose A B C).
Next Obligation.
@@ -396,12 +396,12 @@ Section GenericInstances.
Proof. simpl_crelation. Qed.
(** [respectful] is a morphism for crelation equivalence . *)
- Set Printing All. Set Printing Universes.
+
Global Instance respectful_morphism :
Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence)
(@respectful A B).
Proof.
- intros R R' HRR' S S' HSS' f g.
+ intros A B R R' HRR' S S' HSS' f g.
unfold respectful , relation_equivalence in *; simpl in *.
split ; intros H x y Hxy.
apply (fst (HSS' _ _)). apply H. now apply (snd (HRR' _ _)).
@@ -414,9 +414,9 @@ Section GenericInstances.
Proper R' (m x).
Proof. simpl_crelation. Qed.
- Class Params (of : A) (arity : nat).
+ Class Params {A} (of : A) (arity : nat).
- Lemma flip_respectful (R : crelation A) (R' : crelation B) :
+ Lemma flip_respectful {A B} (R : crelation A) (R' : crelation B) :
relation_equivalence (flip (R ==> R')) (flip R ==> flip R').
Proof.
intros.
@@ -449,7 +449,7 @@ Section GenericInstances.
Lemma reflexive_proper `{Reflexive A R} (x : A) : Proper R x.
Proof. firstorder. Qed.
- Lemma proper_eq (x : A) : Proper (@eq A) x.
+ Lemma proper_eq {A} (x : A) : Proper (@eq A) x.
Proof. intros. apply reflexive_proper. Qed.
End GenericInstances.
diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v
index d2971552..50f853f0 100644
--- a/theories/Init/Logic.v
+++ b/theories/Init/Logic.v
@@ -22,9 +22,6 @@ Inductive True : Prop :=
(** [False] is the always false proposition *)
Inductive False : Prop :=.
-(** [proof_admitted] is used to implement the admit tactic *)
-Axiom proof_admitted : False.
-
(** [not A], written [~A], is the negation of [A] *)
Definition not (A:Prop) := A -> False.
diff --git a/theories/Init/Notations.v b/theories/Init/Notations.v
index 424ca0c8..a7bdba90 100644
--- a/theories/Init/Notations.v
+++ b/theories/Init/Notations.v
@@ -59,7 +59,7 @@ Reserved Notation "( x , y , .. , z )" (at level 0).
(** Notation "{ x }" is reserved and has a special status as component
of other notations such as "{ A } + { B }" and "A + { B }" (which
- are at the same level than "x + y");
+ are at the same level as "x + y");
"{ x }" is at level 0 to factor with "{ x : A | P }" *)
Reserved Notation "{ x }" (at level 0, x at level 99).
diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v
index 4894eba4..0efb8744 100644
--- a/theories/Init/Prelude.v
+++ b/theories/Init/Prelude.v
@@ -23,4 +23,4 @@ Declare ML Module "cc_plugin".
Declare ML Module "ground_plugin".
Declare ML Module "recdef_plugin".
(* Default substrings not considered by queries like SearchAbout *)
-Add Search Blacklist "_admitted" "_subproof" "Private_".
+Add Search Blacklist "_subproof" "Private_".
diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v
index 9e828e6e..a7d3f806 100644
--- a/theories/Init/Tactics.v
+++ b/theories/Init/Tactics.v
@@ -180,12 +180,14 @@ Ltac easy :=
| H : _ |- _ => solve [inversion H]
| _ => idtac
end in
- let rec do_atom :=
- solve [reflexivity | symmetry; trivial] ||
- contradiction ||
- (split; do_atom)
- with do_ccl := trivial with eq_true; repeat do_intro; do_atom in
- (use_hyps; do_ccl) || fail "Cannot solve this goal".
+ let do_atom :=
+ solve [ trivial with eq_true | reflexivity | symmetry; trivial | contradiction ] in
+ let rec do_ccl :=
+ try do_atom;
+ repeat (do_intro; try do_atom);
+ solve [ split; do_ccl ] in
+ solve [ do_atom | use_hyps; do_ccl ] ||
+ fail "Cannot solve this goal".
Tactic Notation "now" tactic(t) := t; easy.
diff --git a/theories/Lists/List.v b/theories/Lists/List.v
index 3cba090f..ea07a849 100644
--- a/theories/Lists/List.v
+++ b/theories/Lists/List.v
@@ -1014,11 +1014,17 @@ Proof.
rewrite IHl; auto.
Qed.
+Lemma map_ext_in :
+ forall (A B : Type)(f g:A->B) l, (forall a, In a l -> f a = g a) -> map f l = map g l.
+Proof.
+ induction l; simpl; auto.
+ intros; rewrite H by intuition; rewrite IHl; auto.
+Qed.
+
Lemma map_ext :
forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l.
Proof.
- induction l; simpl; auto.
- rewrite H; rewrite IHl; auto.
+ intros; apply map_ext_in; auto.
Qed.
diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v
index b57c3f04..c95fb4d5 100644
--- a/theories/Lists/SetoidList.v
+++ b/theories/Lists/SetoidList.v
@@ -613,18 +613,18 @@ induction s1; simpl; auto; intros.
Qed.
Lemma fold_right_equivlistA_restr2 :
- forall s s' (i j:B) (heqij: eqB i j),
+ forall s s' i j,
NoDupA s -> NoDupA s' -> ForallOrdPairs R s ->
- eqB i j ->
- equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s').
+ equivlistA s s' -> eqB i j ->
+ eqB (fold_right f i s) (fold_right f j s').
Proof.
simple induction s.
destruct s'; simpl.
intros. assumption.
unfold equivlistA; intros.
- destruct (H3 a).
+ destruct (H2 a).
assert (InA a nil) by auto; inv.
- intros x l Hrec s' i j heqij N N' F eqij E; simpl in *.
+ intros x l Hrec s' i j N N' F E eqij; simpl in *.
assert (InA x s') by (rewrite <- (E x); auto).
destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))).
subst s'.
@@ -649,7 +649,6 @@ Proof.
red; intros; rewrite E; auto.
Qed.
-
Lemma fold_right_add_restr2 :
forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ForallOrdPairs R s' -> ~ InA x s ->
equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)).
diff --git a/theories/Lists/SetoidPermutation.v b/theories/Lists/SetoidPermutation.v
index afc7c25b..cea3e839 100644
--- a/theories/Lists/SetoidPermutation.v
+++ b/theories/Lists/SetoidPermutation.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-Require Import SetoidList.
+Require Import Permutation SetoidList.
(* Set Universe Polymorphism. *)
Set Implicit Arguments.
@@ -123,4 +123,76 @@ Proof.
apply equivlistA_NoDupA_split with x y; intuition.
Qed.
+Lemma Permutation_eqlistA_commute l₁ l₂ l₃ :
+ eqlistA eqA l₁ l₂ -> Permutation l₂ l₃ ->
+ exists l₂', Permutation l₁ l₂' /\ eqlistA eqA l₂' l₃.
+Proof.
+ intros E P. revert l₁ E.
+ induction P; intros.
+ - inversion_clear E. now exists nil.
+ - inversion_clear E.
+ destruct (IHP l0) as (l0',(P',E')); trivial. clear IHP.
+ exists (x0::l0'). split; auto.
+ - inversion_clear E. inversion_clear H0.
+ exists (x1::x0::l1). now repeat constructor.
+ - clear P1 P2.
+ destruct (IHP1 _ E) as (l₁',(P₁,E₁)).
+ destruct (IHP2 _ E₁) as (l₂',(P₂,E₂)).
+ exists l₂'. split; trivial. econstructor; eauto.
+Qed.
+
+Lemma PermutationA_decompose l₁ l₂ :
+ PermutationA l₁ l₂ ->
+ exists l, Permutation l₁ l /\ eqlistA eqA l l₂.
+Proof.
+ induction 1.
+ - now exists nil.
+ - destruct IHPermutationA as (l,(P,E)). exists (x₁::l); auto.
+ - exists (x::y::l). split. constructor. reflexivity.
+ - destruct IHPermutationA1 as (l₁',(P,E)).
+ destruct IHPermutationA2 as (l₂',(P',E')).
+ destruct (@Permutation_eqlistA_commute l₁' l₂ l₂') as (l₁'',(P'',E''));
+ trivial.
+ exists l₁''. split. now transitivity l₁'. now transitivity l₂'.
+Qed.
+
+Lemma Permutation_PermutationA l₁ l₂ :
+ Permutation l₁ l₂ -> PermutationA l₁ l₂.
+Proof.
+ induction 1.
+ - constructor.
+ - now constructor.
+ - apply permA_swap.
+ - econstructor; eauto.
+Qed.
+
+Lemma eqlistA_PermutationA l₁ l₂ :
+ eqlistA eqA l₁ l₂ -> PermutationA l₁ l₂.
+Proof.
+ induction 1; now constructor.
+Qed.
+
+Lemma NoDupA_equivlistA_decompose l1 l2 :
+ NoDupA eqA l1 -> NoDupA eqA l2 -> equivlistA eqA l1 l2 ->
+ exists l, Permutation l1 l /\ eqlistA eqA l l2.
+Proof.
+ intros. apply PermutationA_decompose.
+ now apply NoDupA_equivlistA_PermutationA.
+Qed.
+
+Lemma PermutationA_preserves_NoDupA l₁ l₂ :
+ PermutationA l₁ l₂ -> NoDupA eqA l₁ -> NoDupA eqA l₂.
+Proof.
+ induction 1; trivial.
+ - inversion_clear 1; constructor; auto.
+ apply PermutationA_equivlistA in H0. contradict H2.
+ now rewrite H, H0.
+ - inversion_clear 1. inversion_clear H1. constructor.
+ + contradict H. inversion_clear H; trivial.
+ elim H0. now constructor.
+ + constructor; trivial.
+ contradict H0. now apply InA_cons_tl.
+ - eauto.
+Qed.
+
End Permutation.
diff --git a/theories/MMaps/MMapAVL.v b/theories/MMaps/MMapAVL.v
new file mode 100644
index 00000000..d840f1f3
--- /dev/null
+++ b/theories/MMaps/MMapAVL.v
@@ -0,0 +1,2158 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(* Finite map library. *)
+
+(** * MMapAVL *)
+
+(** This module implements maps using AVL trees.
+ It follows the implementation from Ocaml's standard library.
+
+ See the comments at the beginning of MSetAVL for more details.
+*)
+
+Require Import Bool PeanoNat BinInt Int MMapInterface MMapList.
+Require Import Orders OrdersFacts OrdersLists.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+(* For nicer extraction, we create inductive principles
+ only when needed *)
+Local Unset Elimination Schemes.
+
+(** Notations and helper lemma about pairs *)
+
+Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope.
+Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope.
+
+(** * 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.
+
+(** * Trees *)
+
+Section Elt.
+
+Variable elt : Type.
+
+(** * Trees
+
+ The fifth field of [Node] is the height of the tree *)
+
+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
+ | Eq => true
+ | Lt => mem x l
+ | 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
+ | Eq => Some d
+ | Lt => find x l
+ | 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 (hr+2) <? hl then
+ match l with
+ | Leaf => assert_false l x d r
+ | Node ll lx ld lr _ =>
+ if (height lr) <=? (height ll) 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 (hl+2) <? hr then
+ match r with
+ | Leaf => assert_false l x d r
+ | Node rl rx rd rr _ =>
+ if (height rl) <=? (height rr) 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
+ | Eq => Node l y d r h
+ | Lt => bal (add x d l) y d' r
+ | 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
+
+ [merge0 t1 t2] builds the union of [t1] and [t2] assuming all elements
+ of [t1] to be smaller than all elements of [t2], and
+ [|height t1 - height t2| <= 2].
+*)
+
+Definition merge0 s1 s2 :=
+ match s1,s2 with
+ | Leaf, _ => s2
+ | _, Leaf => s1
+ | _, Node l2 x2 d2 r2 h2 =>
+ let '(s2',(x,d)) := remove_min l2 x2 d2 r2 in
+ bal s1 x d s2'
+ end.
+
+(** * Deletion *)
+
+Fixpoint remove x m := match m with
+ | Leaf => Leaf
+ | Node l y d r h =>
+ match X.compare x y with
+ | Eq => merge0 l r
+ | Lt => bal (remove x l) y d 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 rh+2 <? lh then bal ll lx ld (join lr x d r)
+ else if lh+2 <? rh then bal (join_aux rl) rx rd rr
+ else create l x d r
+ end
+ end.
+
+(** * Splitting
+
+ [split x m] returns a triple [(l, o, r)] where
+ - [l] is the set of elements of [m] that are [< x]
+ - [r] is the set of elements of [m] that are [> x]
+ - [o] is the result of [find x m].
+*)
+
+Record triple := mktriple { t_left:t; t_opt:option elt; t_right:t }.
+Notation "〚 l , b , r 〛" := (mktriple l b r) (at level 9).
+
+Fixpoint split x m : triple := match m with
+ | Leaf => 〚 Leaf, None, Leaf 〛
+ | Node l y d r h =>
+ match X.compare x y with
+ | Lt => let (ll,o,rl) := split x l in 〚 ll, o, join rl y d r 〛
+ | Eq => 〚 l, Some d, r 〛
+ | Gt => let (rl,o,rr) := split x r in 〚 join l y d rl, o, rr 〛
+ end
+ end.
+
+(** * Concatenation
+
+ Same as [merge] but does not assume anything about heights.
+*)
+
+Definition concat m1 m2 :=
+ match m1, m2 with
+ | Leaf, _ => m2
+ | _ , Leaf => m1
+ | _, Node l2 x2 d2 r2 _ =>
+ let (m2',xd) := remove_min l2 x2 d2 r2 in
+ join m1 xd#1 xd#2 m2'
+ end.
+
+(** * Bindings *)
+
+(** [bindings_aux acc t] catenates the bindings of [t] in infix
+ order to the list [acc] *)
+
+Fixpoint bindings_aux (acc : list (key*elt)) m : list (key*elt) :=
+ match m with
+ | Leaf => acc
+ | Node l x d r _ => bindings_aux ((x,d) :: bindings_aux acc r) l
+ end.
+
+(** then [bindings] is an instantiation with an empty [acc] *)
+
+Definition bindings := bindings_aux nil.
+
+(** * Fold *)
+
+Fixpoint fold {A} (f : key -> elt -> A -> A) (m : t) : A -> A :=
+ fun a => match m with
+ | Leaf => a
+ | Node l x d r _ => fold f r (f x d (fold f l a))
+ end.
+
+(** * Comparison *)
+
+Variable cmp : elt->elt->bool.
+
+(** ** Enumeration of the elements of a tree *)
+
+Inductive enumeration :=
+ | End : enumeration
+ | More : key -> elt -> t -> enumeration -> enumeration.
+
+(** [cons m e] adds the elements of tree [m] on the head of
+ enumeration [e]. *)
+
+Fixpoint cons m e : enumeration :=
+ match m with
+ | Leaf => e
+ | Node l x d r h => cons l (More x d r e)
+ end.
+
+(** One step of comparison of elements *)
+
+Definition equal_more x1 d1 (cont:enumeration->bool) e2 :=
+ match e2 with
+ | End => false
+ | More x2 d2 r2 e2 =>
+ match X.compare x1 x2 with
+ | Eq => cmp d1 d2 &&& cont (cons r2 e2)
+ | _ => false
+ end
+ end.
+
+(** Comparison of left tree, middle element, then right tree *)
+
+Fixpoint equal_cont m1 (cont:enumeration->bool) e2 :=
+ match m1 with
+ | Leaf => cont e2
+ | Node l1 x1 d1 r1 _ =>
+ equal_cont l1 (equal_more x1 d1 (equal_cont r1 cont)) e2
+ end.
+
+(** Initial continuation *)
+
+Definition equal_end e2 := match e2 with End => true | _ => false end.
+
+(** The complete comparison *)
+
+Definition equal m1 m2 := equal_cont m1 equal_end (cons m2 End).
+
+End Elt.
+Notation t := tree.
+Notation "〚 l , b , r 〛" := (mktriple l b r) (at level 9).
+Notation "t #l" := (t_left t) (at level 9, format "t '#l'").
+Notation "t #o" := (t_opt t) (at level 9, format "t '#o'").
+Notation "t #r" := (t_right t) (at level 9, format "t '#r'").
+
+
+(** * Map *)
+
+Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' :=
+ match m with
+ | Leaf _ => Leaf _
+ | Node l x d r h => Node (map f l) x (f d) (map f r) h
+ end.
+
+(* * Mapi *)
+
+Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' :=
+ match m with
+ | Leaf _ => Leaf _
+ | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h
+ end.
+
+(** * Map with removal *)
+
+Fixpoint mapo (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 (mapo f l) x d' (mapo f r)
+ | None => concat (mapo f l) (mapo f r)
+ end
+ end.
+
+(** * Generalized merge
+
+ Suggestion by B. Gregoire: a [merge] 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 GMerge.
+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 gmerge 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 (gmerge l1 l2') x1 e (gmerge r1 r2')
+ | None => concat (gmerge l1 l2') (gmerge r1 r2')
+ end
+ end.
+
+End GMerge.
+
+(** * Merge
+
+ The [merge] function of the Map interface can be implemented
+ via [gmerge] and [mapo].
+*)
+
+Section Merge.
+Variable elt elt' elt'' : Type.
+Variable f : key -> option elt -> option elt' -> option elt''.
+
+Definition merge : t elt -> t elt' -> t elt'' :=
+ gmerge
+ (fun k d o => f k (Some d) o)
+ (mapo (fun k d => f k (Some d) None))
+ (mapo (fun k d' => f k None (Some d'))).
+
+End Merge.
+
+
+
+(** * 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 *)
+
+(** [Above x m] : [x] is strictly greater than any key in [m].
+ [Below x m] : [x] is strictly smaller than any key in [m]. *)
+
+Inductive Above (x:key) : t elt -> Prop :=
+ | AbLeaf : Above x (Leaf _)
+ | AbNode l r h y e : Above x l -> X.lt y x -> Above x r ->
+ Above x (Node l y e r h).
+
+Inductive Below (x:key) : t elt -> Prop :=
+ | BeLeaf : Below x (Leaf _)
+ | BeNode l r h y e : Below x l -> X.lt x y -> Below x r ->
+ Below x (Node l y e r h).
+
+Definition Apart (m1 m2 : t elt) : Prop :=
+ forall x1 x2, In x1 m1 -> In x2 m2 -> X.lt x1 x2.
+
+(** Alternative statements, equivalent with [LtTree] and [GtTree] *)
+
+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 ->
+ Above x l -> Below 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 := MMapList.Raw X.
+
+Local Infix "∈" := In (at level 70).
+Local Infix "==" := X.eq (at level 70).
+Local Infix "<" := X.lt (at level 70).
+Local Infix "<<" := Below (at level 70).
+Local Infix ">>" := Above (at level 70).
+Local Infix "<<<" := Apart (at level 70).
+
+Scheme tree_ind := Induction for tree Sort Prop.
+Scheme Bst_ind := Induction for Bst Sort Prop.
+Scheme MapsTo_ind := Induction for MapsTo Sort Prop.
+Scheme In_ind := Induction for In Sort Prop.
+Scheme Above_ind := Induction for Above Sort Prop.
+Scheme Below_ind := Induction for Below Sort Prop.
+
+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 merge0_ind := Induction for merge0 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 mapo_ind := Induction for mapo Sort Prop.
+Functional Scheme gmerge_ind := Induction for gmerge Sort Prop.
+
+(** * Automation and dedicated tactics. *)
+
+Local Hint Constructors tree MapsTo In Bst Above Below.
+Local Hint Unfold lt_tree gt_tree Apart.
+Local Hint Immediate MX.eq_sym.
+Local Hint Resolve MX.eq_refl MX.eq_trans MX.lt_trans.
+
+Tactic Notation "factornode" ident(s) :=
+ try clear s;
+ match goal with
+ | |- context [Node ?l ?x ?e ?r ?h] =>
+ set (s:=Node l x e r h) in *; clearbody s; clear l x e r h
+ | _ : context [Node ?l ?x ?e ?r ?h] |- _ =>
+ set (s:=Node l x e r h) in *; clearbody s; clear l x e r h
+ end.
+
+(** A tactic for cleaning hypothesis after use of functional induction. *)
+
+Ltac cleanf :=
+ match goal with
+ | H : X.compare _ _ = Eq |- _ =>
+ rewrite ?H; apply MX.compare_eq in H; cleanf
+ | H : X.compare _ _ = Lt |- _ =>
+ rewrite ?H; apply MX.compare_lt_iff in H; cleanf
+ | H : X.compare _ _ = Gt |- _ =>
+ rewrite ?H; apply MX.compare_gt_iff in H; cleanf
+ | _ => 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.
+
+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 l x d r :=
+ revert x d r;
+ 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 (rh+2 <? lh) eqn:LT;
+ [ 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 (lh+2 <? rh) eqn:LT';
+ [ match goal with |- context [ bal ?u ?v ?w ?z ] =>
+ replace (bal u v w z)
+ with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto]
+ end
+ | ] ] ] ]; intros.
+
+Ltac cleansplit :=
+ simpl; cleanf; inv Bst;
+ match goal with
+ | E:split _ _ = 〚 ?l, ?o, ?r 〛 |- _ =>
+ change l with (〚l,o,r〛#l); rewrite <- ?E;
+ change o with (〚l,o,r〛#o); rewrite <- ?E;
+ change r with (〚l,o,r〛#r); rewrite <- ?E
+ | _ => idtac
+ end.
+
+(** * Basic results about [MapsTo], [In], [lt_tree], [gt_tree], [height] *)
+
+(** Facts about [MapsTo] and [In]. *)
+
+Lemma MapsTo_In {elt} k (e:elt) m : MapsTo k e m -> k ∈ m.
+Proof.
+ induction 1; auto.
+Qed.
+Local Hint Resolve MapsTo_In.
+
+Lemma In_MapsTo {elt} k m : k ∈ m -> exists (e:elt), MapsTo k e m.
+Proof.
+ induction 1; try destruct IHIn as (e,He); exists e; auto.
+Qed.
+
+Lemma In_alt {elt} k (m:t elt) : In0 k m <-> k ∈ m.
+Proof.
+ split.
+ intros (e,H); eauto.
+ unfold In0; apply In_MapsTo; auto.
+Qed.
+
+Lemma MapsTo_1 {elt} m x y (e:elt) :
+ x == y -> MapsTo x e m -> MapsTo y e m.
+Proof.
+ induction m; simpl; intuition_in; eauto.
+Qed.
+Hint Immediate MapsTo_1.
+
+Instance MapsTo_compat {elt} :
+ Proper (X.eq==>Logic.eq==>Logic.eq==>iff) (@MapsTo elt).
+Proof.
+ intros x x' Hx e e' He m m' Hm. subst.
+ split; now apply MapsTo_1.
+Qed.
+
+Instance In_compat {elt} :
+ Proper (X.eq==>Logic.eq==>iff) (@In elt).
+Proof.
+ intros x x' H m m' <-.
+ induction m; simpl; intuition_in; eauto.
+Qed.
+
+Lemma In_node_iff {elt} l x (e:elt) r h y :
+ y ∈ (Node l x e r h) <-> y ∈ l \/ y == x \/ y ∈ r.
+Proof.
+ intuition_in.
+Qed.
+
+(** Results about [Above] and [Below] *)
+
+Lemma above {elt} (m:t elt) x :
+ x >> m <-> forall y, y ∈ m -> y < x.
+Proof.
+ split.
+ - induction 1; intuition_in; MX.order.
+ - induction m; constructor; auto.
+Qed.
+
+Lemma below {elt} (m:t elt) x :
+ x << m <-> forall y, y ∈ m -> x < y.
+Proof.
+ split.
+ - induction 1; intuition_in; MX.order.
+ - induction m; constructor; auto.
+Qed.
+
+Lemma AboveLt {elt} (m:t elt) x y : x >> m -> y ∈ m -> y < x.
+Proof.
+ rewrite above; intuition.
+Qed.
+
+Lemma BelowGt {elt} (m:t elt) x y : x << m -> y ∈ m -> x < y.
+Proof.
+ rewrite below; intuition.
+Qed.
+
+Lemma Above_not_In {elt} (m:t elt) x : x >> m -> ~ x ∈ m.
+Proof.
+ induction 1; intuition_in; MX.order.
+Qed.
+
+Lemma Below_not_In {elt} (m:t elt) x : x << m -> ~ x ∈ m.
+Proof.
+ induction 1; intuition_in; MX.order.
+Qed.
+
+Lemma Above_trans {elt} (m:t elt) x y : x < y -> x >> m -> y >> m.
+Proof.
+ induction 2; constructor; trivial; MX.order.
+Qed.
+
+Lemma Below_trans {elt} (m:t elt) x y : y < x -> x << m -> y << m.
+Proof.
+ induction 2; constructor; trivial; MX.order.
+Qed.
+
+Local Hint Resolve
+ AboveLt Above_not_In Above_trans
+ BelowGt Below_not_In Below_trans.
+
+(** Helper tactic concerning order of elements. *)
+
+Ltac order := match goal with
+ | U: _ >> ?m, V: _ ∈ ?m |- _ =>
+ generalize (AboveLt U V); clear U; order
+ | U: _ << ?m, V: _ ∈ ?m |- _ =>
+ generalize (BelowGt U V); clear U; order
+ | U: _ >> ?m, V: MapsTo _ _ ?m |- _ =>
+ generalize (AboveLt U (MapsTo_In V)); clear U; order
+ | U: _ << ?m, V: MapsTo _ _ ?m |- _ =>
+ generalize (BelowGt U (MapsTo_In V)); clear U; order
+ | _ => MX.order
+end.
+
+Lemma between {elt} (m m':t elt) x :
+ x >> m -> x << m' -> m <<< m'.
+Proof.
+ intros H H' y y' Hy Hy'. order.
+Qed.
+
+Section Elt.
+Variable elt:Type.
+Implicit Types m r : t elt.
+
+(** * Membership *)
+
+Lemma find_1 m x e : Bst m -> MapsTo x e m -> find x m = Some e.
+Proof.
+ functional induction (find x m); cleanf;
+ intros; inv Bst; intuition_in; order.
+Qed.
+
+Lemma find_2 m x e : find x m = Some e -> MapsTo x e m.
+Proof.
+ functional induction (find x m); cleanf; subst; intros; auto.
+ - discriminate.
+ - injection H as ->. auto.
+Qed.
+
+Lemma find_spec 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 m x : find x m <> None -> x ∈ m.
+Proof.
+ destruct (find x m) eqn:F; intros H.
+ - apply MapsTo_In with e. now apply find_2.
+ - now elim H.
+Qed.
+
+Lemma in_find m x : Bst m -> x ∈ m -> find x m <> None.
+Proof.
+ intros H H'.
+ destruct (In_MapsTo H') as (d,Hd).
+ now rewrite (find_1 H Hd).
+Qed.
+
+Lemma find_in_iff m x : Bst m ->
+ (find x m <> None <-> x ∈ m).
+Proof.
+ split; auto using find_in, in_find.
+Qed.
+
+Lemma not_find_iff m x : Bst m ->
+ (find x m = None <-> ~ x ∈ m).
+Proof.
+ intros H. rewrite <- find_in_iff; trivial.
+ destruct (find x m); split; try easy. now destruct 1.
+Qed.
+
+Lemma eq_option_alt (o o':option elt) :
+ o=o' <-> (forall e, o=Some e <-> o'=Some e).
+Proof.
+split; intros.
+- now subst.
+- destruct o, o'; rewrite ?H; auto. symmetry; now apply H.
+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 eq_option_alt.
+ split; intros H d. now rewrite <- 2 find_spec. now rewrite 2 find_spec.
+Qed.
+
+Lemma find_in_equiv : forall m m' x, Bst m -> Bst m' ->
+ find x m = find x m' ->
+ (x ∈ m <-> x ∈ m').
+Proof.
+ split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ];
+ apply in_find; auto.
+Qed.
+
+Lemma find_compat m x x' : Bst m -> X.eq x x' -> find x m = find x' m.
+Proof.
+ intros B E.
+ destruct (find x' m) eqn:H.
+ - apply find_1; trivial. rewrite E. now apply find_2.
+ - rewrite not_find_iff in *; trivial. now rewrite E.
+Qed.
+
+Lemma mem_spec m x : Bst m -> mem x m = true <-> x ∈ m.
+Proof.
+ functional induction (mem x m); auto; intros; cleanf;
+ inv Bst; intuition_in; try discriminate; order.
+Qed.
+
+(** * Empty map *)
+
+Lemma empty_bst : Bst (empty elt).
+Proof.
+ constructor.
+Qed.
+
+Lemma empty_spec x : find x (empty elt) = None.
+Proof.
+ reflexivity.
+Qed.
+
+(** * Emptyness test *)
+
+Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None.
+Proof.
+ destruct m as [|r x e l h]; simpl; split; try easy.
+ intros H. specialize (H x). now rewrite MX.compare_refl in H.
+Qed.
+
+(** * Helper functions *)
+
+Lemma create_bst l x e r :
+ Bst l -> Bst r -> x >> l -> x << r -> Bst (create l x e r).
+Proof.
+ unfold create; auto.
+Qed.
+Hint Resolve create_bst.
+
+Lemma create_in l x e r y :
+ y ∈ (create l x e r) <-> y == x \/ y ∈ l \/ y ∈ r.
+Proof.
+ unfold create; split; [ inversion_clear 1 | ]; intuition.
+Qed.
+
+Lemma bal_bst l x e r : Bst l -> Bst r ->
+ x >> l -> x << r -> Bst (bal l x e r).
+Proof.
+ functional induction (bal l x e r); intros; cleanf;
+ inv Bst; inv Above; inv Below;
+ repeat apply create_bst; auto; unfold create; constructor; eauto.
+Qed.
+Hint Resolve bal_bst.
+
+Lemma bal_in l x e r y :
+ y ∈ (bal l x e r) <-> y == x \/ y ∈ l \/ y ∈ r.
+Proof.
+ functional induction (bal l x e r); intros; cleanf;
+ rewrite !create_in; intuition_in.
+Qed.
+
+Lemma bal_mapsto l x e r y e' :
+ MapsTo y e' (bal l x e r) <-> MapsTo y e' (create l x e r).
+Proof.
+ functional induction (bal l x e r); intros; cleanf;
+ unfold assert_false, create; intuition_in.
+Qed.
+
+Lemma bal_find l x e r y :
+ Bst l -> Bst r -> x >> l -> x << r ->
+ find y (bal l x e r) = find y (create l x e r).
+Proof.
+ functional induction (bal l x e r); intros; cleanf; trivial;
+ inv Bst; inv Above; inv Below;
+ simpl; repeat case X.compare_spec; intuition; order.
+Qed.
+
+(** * Insertion *)
+
+Lemma add_in m x y e :
+ y ∈ (add x e m) <-> y == x \/ y ∈ m.
+Proof.
+ functional induction (add x e m); auto; intros; cleanf;
+ rewrite ?bal_in; intuition_in. setoid_replace y with x; auto.
+Qed.
+
+Lemma add_lt m x e y : y >> m -> x < y -> y >> add x e m.
+Proof.
+ intros. apply above. intros z. rewrite add_in. destruct 1; order.
+Qed.
+
+Lemma add_gt m x e y : y << m -> y < x -> y << add x e m.
+Proof.
+ intros. apply below. intros z. rewrite add_in. destruct 1; order.
+Qed.
+
+Lemma add_bst m x e : Bst m -> Bst (add x e m).
+Proof.
+ functional induction (add x e m); intros; cleanf;
+ inv Bst; try apply bal_bst; auto using add_lt, add_gt.
+Qed.
+Hint Resolve add_lt add_gt add_bst.
+
+Lemma add_spec1 m x e : Bst m -> find x (add x e m) = Some e.
+Proof.
+ functional induction (add x e m); simpl; intros; cleanf; trivial.
+ - now rewrite MX.compare_refl.
+ - inv Bst. rewrite bal_find; auto.
+ simpl. case X.compare_spec; try order; auto.
+ - inv Bst. rewrite bal_find; auto.
+ simpl. case X.compare_spec; try order; auto.
+Qed.
+
+Lemma add_spec2 m x y e : Bst m -> ~ x == y ->
+ find y (add x e m) = find y m.
+Proof.
+ functional induction (add x e m); simpl; intros; cleanf; trivial.
+ - case X.compare_spec; trivial; order.
+ - case X.compare_spec; trivial; order.
+ - inv Bst. rewrite bal_find by auto. simpl. now rewrite IHt.
+ - inv Bst. rewrite bal_find by auto. simpl. now rewrite IHt.
+Qed.
+
+Lemma add_find 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.
+ case X.compare_spec; intros.
+ - apply find_spec; auto. rewrite H0. apply find_spec; auto.
+ now apply add_spec1.
+ - apply add_spec2; trivial; order.
+ - apply add_spec2; trivial; order.
+Qed.
+
+(** * Extraction of minimum binding *)
+
+Definition RemoveMin m res :=
+ match m with
+ | Leaf _ => False
+ | Node l x e r h => remove_min l x e r = res
+ end.
+
+Lemma RemoveMin_step l x e r h m' p :
+ RemoveMin (Node l x e r h) (m',p) ->
+ (l = Leaf _ /\ m' = r /\ p = (x,e) \/
+ exists m0, RemoveMin l (m0,p) /\ m' = bal m0 x e r).
+Proof.
+ simpl. destruct l as [|ll lx le lr lh]; simpl.
+ - intros [= -> ->]. now left.
+ - destruct (remove_min ll lx le lr) as (l',p').
+ intros [= <- <-]. right. now exists l'.
+Qed.
+
+Lemma remove_min_mapsto m m' p : RemoveMin m (m',p) ->
+ forall y e,
+ MapsTo y e m <-> (y == p#1 /\ e = p#2) \/ MapsTo y e m'.
+Proof.
+ revert m'.
+ induction m as [|l IH x d r _ h]; [destruct 1|].
+ intros m' R. apply RemoveMin_step in R.
+ destruct R as [(->,(->,->))|[m0 (R,->)]]; intros y e; simpl.
+ - intuition_in. subst. now constructor.
+ - rewrite bal_mapsto. unfold create. specialize (IH _ R y e).
+ intuition_in.
+Qed.
+
+Lemma remove_min_in m m' p : RemoveMin m (m',p) ->
+ forall y, y ∈ m <-> y == p#1 \/ y ∈ m'.
+Proof.
+ revert m'.
+ induction m as [|l IH x e r _ h]; [destruct 1|].
+ intros m' R y. apply RemoveMin_step in R.
+ destruct R as [(->,(->,->))|[m0 (R,->)]].
+ + intuition_in.
+ + rewrite bal_in, In_node_iff, (IH _ R); intuition.
+Qed.
+
+Lemma remove_min_lt m m' p : RemoveMin m (m',p) ->
+ forall y, y >> m -> y >> m'.
+Proof.
+ intros R y L. apply above. intros z Hz.
+ apply (AboveLt L).
+ apply (remove_min_in R). now right.
+Qed.
+
+Lemma remove_min_gt m m' p : RemoveMin m (m',p) ->
+ Bst m -> p#1 << m'.
+Proof.
+ revert m'.
+ induction m as [|l IH x e r _ h]; [destruct 1|].
+ intros m' R H. inv Bst. apply RemoveMin_step in R.
+ destruct R as [(_,(->,->))|[m0 (R,->)]]; auto.
+ assert (p#1 << m0) by now apply IH.
+ assert (In p#1 l) by (apply (remove_min_in R); now left).
+ apply below. intros z. rewrite bal_in.
+ intuition_in; order.
+Qed.
+
+Lemma remove_min_bst m m' p : RemoveMin m (m',p) ->
+ Bst m -> Bst m'.
+Proof.
+ revert m'.
+ induction m as [|l IH x e r _ h]; [destruct 1|].
+ intros m' R H. inv Bst. apply RemoveMin_step in R.
+ destruct R as [(_,(->,->))|[m0 (R,->)]]; auto.
+ apply bal_bst; eauto using remove_min_lt.
+Qed.
+
+Lemma remove_min_find m m' p : RemoveMin m (m',p) ->
+ Bst m ->
+ forall y,
+ find y m =
+ match X.compare y p#1 with
+ | Eq => Some p#2
+ | Lt => None
+ | Gt => find y m'
+ end.
+Proof.
+ revert m'.
+ induction m as [|l IH x e r _ h]; [destruct 1|].
+ intros m' R B y. inv Bst. apply RemoveMin_step in R.
+ destruct R as [(->,(->,->))|[m0 (R,->)]]; auto.
+ assert (Bst m0) by now apply (remove_min_bst R).
+ assert (p#1 << m0) by now apply (remove_min_gt R).
+ assert (x >> m0) by now apply (remove_min_lt R).
+ assert (In p#1 l) by (apply (remove_min_in R); now left).
+ simpl in *.
+ rewrite (IH _ R), bal_find by trivial. clear IH. simpl.
+ do 2 case X.compare_spec; trivial; try order.
+Qed.
+
+(** * Merging two trees *)
+
+Ltac factor_remove_min m R := match goal with
+ | h:int, H:remove_min ?l ?x ?e ?r = ?p |- _ =>
+ assert (R:RemoveMin (Node l x e r h) p) by exact H;
+ set (m:=Node l x e r h) in *; clearbody m; clear H l x e r
+end.
+
+Lemma merge0_in m1 m2 y :
+ y ∈ (merge0 m1 m2) <-> y ∈ m1 \/ y ∈ m2.
+Proof.
+ functional induction (merge0 m1 m2); intros; try factornode m1.
+ - intuition_in.
+ - intuition_in.
+ - factor_remove_min l R. rewrite bal_in, (remove_min_in R).
+ simpl; intuition.
+Qed.
+
+Lemma merge0_mapsto m1 m2 y e :
+ MapsTo y e (merge0 m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2.
+Proof.
+ functional induction (merge0 m1 m2); intros; try factornode m1.
+ - intuition_in.
+ - intuition_in.
+ - factor_remove_min l R. rewrite bal_mapsto, (remove_min_mapsto R).
+ simpl. unfold create; intuition_in. subst. now constructor.
+Qed.
+
+Lemma merge0_bst m1 m2 : Bst m1 -> Bst m2 -> m1 <<< m2 ->
+ Bst (merge0 m1 m2).
+Proof.
+ functional induction (merge0 m1 m2); intros B1 B2 B12; trivial.
+ factornode m1. factor_remove_min l R.
+ apply bal_bst; auto.
+ - eapply remove_min_bst; eauto.
+ - apply above. intros z Hz. apply B12; trivial.
+ rewrite (remove_min_in R). now left.
+ - now apply (remove_min_gt R).
+Qed.
+Hint Resolve merge0_bst.
+
+(** * Deletion *)
+
+Lemma remove_in m x y : Bst m ->
+ (y ∈ remove x m <-> ~ y == x /\ y ∈ m).
+Proof.
+ functional induction (remove x m); simpl; intros; cleanf; inv Bst;
+ rewrite ?merge0_in, ?bal_in, ?IHt; intuition_in; order.
+Qed.
+
+Lemma remove_lt m x y : Bst m -> y >> m -> y >> remove x m.
+Proof.
+ intros. apply above. intro. rewrite remove_in by trivial.
+ destruct 1; order.
+Qed.
+
+Lemma remove_gt m x y : Bst m -> y << m -> y << remove x m.
+Proof.
+ intros. apply below. intro. rewrite remove_in by trivial.
+ destruct 1; order.
+Qed.
+
+Lemma remove_bst m x : Bst m -> Bst (remove x m).
+Proof.
+ functional induction (remove x m); simpl; intros; cleanf; inv Bst.
+ - trivial.
+ - apply merge0_bst; eauto.
+ - apply bal_bst; auto using remove_lt.
+ - apply bal_bst; auto using remove_gt.
+Qed.
+Hint Resolve remove_bst remove_gt remove_lt.
+
+Lemma remove_spec1 m x : Bst m -> find x (remove x m) = None.
+Proof.
+ intros. apply not_find_iff; auto. rewrite remove_in; intuition.
+Qed.
+
+Lemma remove_spec2 m x y : Bst m -> ~ x == y ->
+ find y (remove x m) = find y m.
+Proof.
+ functional induction (remove x m); simpl; intros; cleanf; inv Bst.
+ - trivial.
+ - case X.compare_spec; intros; try order;
+ rewrite find_mapsto_equiv; auto.
+ + intros. rewrite merge0_mapsto; intuition; order.
+ + apply merge0_bst; auto. red; intros; transitivity y0; order.
+ + intros. rewrite merge0_mapsto; intuition; order.
+ + apply merge0_bst; auto. now apply between with y0.
+ - rewrite bal_find by auto. simpl. case X.compare_spec; auto.
+ - rewrite bal_find by auto. simpl. case X.compare_spec; auto.
+Qed.
+
+(** * join *)
+
+Lemma join_in l x d r y :
+ y ∈ (join l x d r) <-> y == x \/ y ∈ l \/ y ∈ r.
+Proof.
+ join_tac l x d r.
+ - simpl join. 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 l x d r :
+ Bst (create l x d r) -> Bst (join l x d r).
+Proof.
+ join_tac l x d r; unfold create in *;
+ inv Bst; inv Above; inv Below; auto.
+ - simpl. auto.
+ - apply bal_bst; auto.
+ apply below. intro. rewrite join_in. intuition_in; order.
+ - apply bal_bst; auto.
+ apply above. intro. rewrite join_in. intuition_in; order.
+Qed.
+Hint Resolve join_bst.
+
+Lemma join_find l x d r y :
+ Bst (create l x d r) ->
+ find y (join l x d r) = find y (create l x d r).
+Proof.
+ unfold create at 1.
+ join_tac l x d r; trivial.
+ - simpl in *. inv Bst.
+ rewrite add_find; trivial.
+ case X.compare_spec; intros; trivial.
+ apply not_find_iff; auto. intro. order.
+ - clear Hlr. factornode l. simpl. inv Bst.
+ rewrite add_find by auto.
+ case X.compare_spec; intros; trivial.
+ apply not_find_iff; auto. intro. order.
+ - clear Hrl LT. factornode r. inv Bst; inv Above; inv Below.
+ rewrite bal_find; auto; simpl.
+ + rewrite Hlr; auto; simpl.
+ repeat (case X.compare_spec; trivial; try order).
+ + apply below. intro. rewrite join_in. intuition_in; order.
+ - clear Hlr LT LT'. factornode l. inv Bst; inv Above; inv Below.
+ rewrite bal_find; auto; simpl.
+ + rewrite Hrl; auto; simpl.
+ repeat (case X.compare_spec; trivial; try order).
+ + apply above. intro. rewrite join_in. intuition_in; order.
+Qed.
+
+(** * split *)
+
+Lemma split_in_l0 m x y : y ∈ (split x m)#l -> y ∈ m.
+Proof.
+ functional induction (split x m); cleansplit;
+ rewrite ?join_in; intuition.
+Qed.
+
+Lemma split_in_r0 m x y : y ∈ (split x m)#r -> y ∈ m.
+Proof.
+ functional induction (split x m); cleansplit;
+ rewrite ?join_in; intuition.
+Qed.
+
+Lemma split_in_l m x y : Bst m ->
+ (y ∈ (split x m)#l <-> y ∈ m /\ y < x).
+Proof.
+ functional induction (split x m); intros; cleansplit;
+ rewrite ?join_in, ?IHt; intuition_in; order.
+Qed.
+
+Lemma split_in_r m x y : Bst m ->
+ (y ∈ (split x m)#r <-> y ∈ m /\ x < y).
+Proof.
+ functional induction (split x m); intros; cleansplit;
+ rewrite ?join_in, ?IHt; intuition_in; order.
+Qed.
+
+Lemma split_in_o m x : (split x m)#o = find x m.
+Proof.
+ functional induction (split x m); intros; cleansplit; auto.
+Qed.
+
+Lemma split_lt_l m x : Bst m -> x >> (split x m)#l.
+Proof.
+ intro. apply above. intro. rewrite split_in_l; intuition; order.
+Qed.
+
+Lemma split_lt_r m x y : y >> m -> y >> (split x m)#r.
+Proof.
+ intro. apply above. intros z Hz. apply split_in_r0 in Hz. order.
+Qed.
+
+Lemma split_gt_r m x : Bst m -> x << (split x m)#r.
+Proof.
+ intro. apply below. intro. rewrite split_in_r; intuition; order.
+Qed.
+
+Lemma split_gt_l m x y : y << m -> y << (split x m)#l.
+Proof.
+ intro. apply below. intros z Hz. apply split_in_l0 in Hz. order.
+Qed.
+Hint Resolve split_lt_l split_lt_r split_gt_l split_gt_r.
+
+Lemma split_bst_l m x : Bst m -> Bst (split x m)#l.
+Proof.
+ functional induction (split x m); intros; cleansplit; intuition;
+ auto using join_bst.
+Qed.
+
+Lemma split_bst_r m x : Bst m -> Bst (split x m)#r.
+Proof.
+ functional induction (split x m); intros; cleansplit; intuition;
+ auto using join_bst.
+Qed.
+Hint Resolve split_bst_l split_bst_r.
+
+Lemma split_find m x y : Bst m ->
+ find y m = match X.compare y x with
+ | Eq => (split x m)#o
+ | Lt => find y (split x m)#l
+ | Gt => find y (split x m)#r
+ end.
+Proof.
+ functional induction (split x m); intros; cleansplit.
+ - now case X.compare.
+ - repeat case X.compare_spec; trivial; order.
+ - simpl in *. rewrite join_find, IHt; auto.
+ simpl. repeat case X.compare_spec; trivial; order.
+ - rewrite join_find, IHt; auto.
+ simpl; repeat case X.compare_spec; trivial; order.
+Qed.
+
+(** * Concatenation *)
+
+Lemma concat_in m1 m2 y :
+ y ∈ (concat m1 m2) <-> y ∈ m1 \/ y ∈ m2.
+Proof.
+ functional induction (concat m1 m2); intros; try factornode m1.
+ - intuition_in.
+ - intuition_in.
+ - factor_remove_min m2 R.
+ rewrite join_in, (remove_min_in R); simpl; intuition.
+Qed.
+
+Lemma concat_bst m1 m2 : Bst m1 -> Bst m2 -> m1 <<< m2 ->
+ Bst (concat m1 m2).
+Proof.
+ functional induction (concat m1 m2); intros B1 B2 LT; auto;
+ try factornode m1.
+ factor_remove_min m2 R.
+ apply join_bst, create_bst; auto.
+ - now apply (remove_min_bst R).
+ - apply above. intros y Hy. apply LT; trivial.
+ rewrite (remove_min_in R); now left.
+ - now apply (remove_min_gt R).
+Qed.
+Hint Resolve concat_bst.
+
+Definition oelse {A} (o1 o2:option A) :=
+ match o1 with
+ | Some x => Some x
+ | None => o2
+ end.
+
+Lemma concat_find m1 m2 y : Bst m1 -> Bst m2 -> m1 <<< m2 ->
+ find y (concat m1 m2) = oelse (find y m2) (find y m1).
+Proof.
+ functional induction (concat m1 m2); intros B1 B2 B; auto; try factornode m1.
+ - destruct (find y m2); auto.
+ - factor_remove_min m2 R.
+ assert (xd#1 >> m1).
+ { apply above. intros z Hz. apply B; trivial.
+ rewrite (remove_min_in R). now left. }
+ rewrite join_find; simpl; auto.
+ + rewrite (remove_min_find R B2 y).
+ case X.compare_spec; intros; auto.
+ destruct (find y m2'); trivial.
+ simpl. symmetry. apply not_find_iff; eauto.
+ + apply create_bst; auto.
+ * now apply (remove_min_bst R).
+ * now apply (remove_min_gt R).
+Qed.
+
+
+(** * Elements *)
+
+Notation eqk := (PX.eqk (elt:= elt)).
+Notation eqke := (PX.eqke (elt:= elt)).
+Notation ltk := (PX.ltk (elt:= elt)).
+
+Lemma bindings_aux_mapsto : forall (s:t elt) acc x e,
+ InA eqke (x,e) (bindings_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.
+ compute in H0. destruct H0; simpl in *; subst; intuition.
+Qed.
+
+Lemma bindings_mapsto : forall (s:t elt) x e,
+ InA eqke (x,e) (bindings s) <-> MapsTo x e s.
+Proof.
+ intros; generalize (bindings_aux_mapsto s nil x e); intuition.
+ inversion_clear H0.
+Qed.
+
+Lemma bindings_in : forall (s:t elt) x, L.PX.In x (bindings s) <-> x ∈ s.
+Proof.
+ intros.
+ unfold L.PX.In.
+ rewrite <- In_alt; unfold In0.
+ split; intros (y,H); exists y.
+ - now rewrite <- bindings_mapsto.
+ - unfold L.PX.MapsTo; now rewrite bindings_mapsto.
+Qed.
+
+Lemma bindings_aux_sort : forall (s:t elt) acc,
+ Bst s -> sort ltk acc ->
+ (forall x e y, InA eqke (x,e) acc -> y ∈ s -> y < x) ->
+ sort ltk (bindings_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.
+ + clear Hl Hr.
+ apply InA_InfA with (eqA:=eqke); auto with *.
+ intros (y',e') Hy'.
+ apply bindings_aux_mapsto in Hy'. compute. intuition; eauto.
+ - clear Hl Hr. intros x e' y' Hx Hy'.
+ inversion_clear Hx.
+ + compute in H. destruct H; simpl in *. order.
+ + apply bindings_aux_mapsto in H. intuition eauto.
+Qed.
+
+Lemma bindings_sort : forall s : t elt, Bst s -> sort ltk (bindings s).
+Proof.
+ intros; unfold bindings; apply bindings_aux_sort; auto.
+ intros; inversion H0.
+Qed.
+Hint Resolve bindings_sort.
+
+Lemma bindings_nodup : forall s : t elt, Bst s -> NoDupA eqk (bindings s).
+Proof.
+ intros; apply PX.Sort_NoDupA; auto.
+Qed.
+
+Lemma bindings_aux_cardinal m acc :
+ (length acc + cardinal m)%nat = length (bindings_aux acc m).
+Proof.
+ revert acc. induction m; simpl; intuition.
+ rewrite <- IHm1; simpl.
+ rewrite <- IHm2. rewrite Nat.add_succ_r, <- Nat.add_assoc.
+ f_equal. f_equal. apply Nat.add_comm.
+Qed.
+
+Lemma bindings_cardinal m : cardinal m = length (bindings m).
+Proof.
+ exact (bindings_aux_cardinal m nil).
+Qed.
+
+Lemma bindings_app :
+ forall (s:t elt) acc, bindings_aux acc s = bindings s ++ acc.
+Proof.
+ induction s; simpl; intros; auto.
+ rewrite IHs1, IHs2.
+ unfold bindings; simpl.
+ rewrite 2 IHs1, IHs2, !app_nil_r, !app_ass; auto.
+Qed.
+
+Lemma bindings_node :
+ forall (t1 t2:t elt) x e z l,
+ bindings t1 ++ (x,e) :: bindings t2 ++ l =
+ bindings (Node t1 x e t2 z) ++ l.
+Proof.
+ unfold bindings; simpl; intros.
+ rewrite !bindings_app, !app_nil_r, !app_ass; auto.
+Qed.
+
+(** * Fold *)
+
+Definition fold' {A} (f : key -> elt -> A -> A)(s : t elt) :=
+ L.fold f (bindings s).
+
+Lemma fold_equiv_aux {A} (s : t elt) (f : key -> elt -> A -> A) (a : A) acc :
+ L.fold f (bindings_aux acc s) a = L.fold f acc (fold f s a).
+Proof.
+ revert a acc.
+ induction s; simpl; trivial.
+ intros. rewrite IHs1. simpl. apply IHs2.
+Qed.
+
+Lemma fold_equiv {A} (s : t elt) (f : key -> elt -> A -> A) (a : A) :
+ fold f s a = fold' f s a.
+Proof.
+ unfold fold', bindings. now rewrite fold_equiv_aux.
+Qed.
+
+Lemma fold_spec (s:t elt)(Hs:Bst s){A}(i:A)(f : key -> elt -> A -> A) :
+ fold f s i = fold_left (fun a p => f p#1 p#2 a) (bindings s) i.
+Proof.
+ rewrite fold_equiv. unfold fold'. now rewrite L.fold_spec.
+Qed.
+
+(** * Comparison *)
+
+(** [flatten_e e] returns the list of bindings of the enumeration [e]
+ i.e. the list of bindings actually compared *)
+
+Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with
+ | End _ => nil
+ | More x e t r => (x,e) :: bindings t ++ flatten_e r
+ end.
+
+Lemma flatten_e_bindings :
+ forall (l:t elt) r x d z e,
+ bindings l ++ flatten_e (More x d r e) =
+ bindings (Node l x d r z) ++ flatten_e e.
+Proof.
+ intros; apply bindings_node.
+Qed.
+
+Lemma cons_1 : forall (s:t elt) e,
+ flatten_e (cons s e) = bindings s ++ flatten_e e.
+Proof.
+ induction s; auto; intros.
+ simpl flatten_e; rewrite IHs1; apply flatten_e_bindings; 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; case X.compare_spec; 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 (bindings 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) (bindings m1 ++ l) (flatten_e e2).
+Proof.
+ induction m1 as [|l1 Hl1 x1 d1 r1 Hr1 h1]; intros; auto.
+ rewrite <- bindings_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) (bindings m1) (bindings m2).
+Proof.
+ intros; unfold equal.
+ rewrite <- (app_nil_r (bindings m1)).
+ replace (bindings 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_bindings : forall s s',
+ Equivb s s' <-> L.Equivb cmp (bindings s) (bindings s').
+Proof.
+unfold Equivb, L.Equivb; split; split; intros.
+do 2 rewrite bindings_in; firstorder.
+destruct H.
+apply (H2 k); rewrite <- bindings_mapsto; auto.
+do 2 rewrite <- bindings_in; firstorder.
+destruct H.
+apply (H2 k); unfold L.PX.MapsTo; rewrite bindings_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_bindings, <- 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_spec m x :
+ find x (map f m) = option_map f (find x m).
+Proof.
+induction m; simpl; trivial. case X.compare_spec; auto.
+Qed.
+
+Lemma map_in m x : x ∈ (map f m) <-> x ∈ m.
+Proof.
+induction m; simpl; intuition_in.
+Qed.
+
+Lemma map_bst m : Bst m -> Bst (map f m).
+Proof.
+induction m; simpl; auto. intros; inv Bst; constructor; auto.
+- apply above. intro. rewrite map_in. intros. order.
+- apply below. intro. rewrite map_in. intros. order.
+Qed.
+
+End Map.
+Section Mapi.
+Variable elt elt' : Type.
+Variable f : key -> elt -> elt'.
+
+Lemma mapi_spec m x :
+ exists y:key,
+ X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+Proof.
+ induction m; simpl.
+ - now exists x.
+ - case X.compare_spec; simpl; auto. intros. now exists k.
+Qed.
+
+Lemma mapi_in m x : x ∈ (mapi f m) <-> x ∈ m.
+Proof.
+induction m; simpl; intuition_in.
+Qed.
+
+Lemma mapi_bst m : Bst m -> Bst (mapi f m).
+Proof.
+induction m; simpl; auto. intros; inv Bst; constructor; auto.
+- apply above. intro. rewrite mapi_in. intros. order.
+- apply below. intro. rewrite mapi_in. intros. order.
+Qed.
+
+End Mapi.
+
+Section Mapo.
+Variable elt elt' : Type.
+Variable f : key -> elt -> option elt'.
+
+Lemma mapo_in m x :
+ x ∈ (mapo f m) ->
+ exists y d, X.eq y x /\ MapsTo x d m /\ f y d <> None.
+Proof.
+functional induction (mapo f m); simpl; auto; intro H.
+- inv In.
+- rewrite join_in in H; destruct H as [H|[H|H]].
+ + exists x0, d. do 2 (split; auto). congruence.
+ + destruct (IHt H) as (y & e & ? & ? & ?). exists y, e. auto.
+ + destruct (IHt0 H) as (y & e & ? & ? & ?). exists y, e. auto.
+- rewrite concat_in in H; destruct H as [H|H].
+ + destruct (IHt H) as (y & e & ? & ? & ?). exists y, e. auto.
+ + destruct (IHt0 H) as (y & e & ? & ? & ?). exists y, e. auto.
+Qed.
+
+Lemma mapo_lt m x : x >> m -> x >> mapo f m.
+Proof.
+ intros H. apply above. intros y Hy.
+ destruct (mapo_in Hy) as (y' & e & ? & ? & ?). order.
+Qed.
+
+Lemma mapo_gt m x : x << m -> x << mapo f m.
+Proof.
+ intros H. apply below. intros y Hy.
+ destruct (mapo_in Hy) as (y' & e & ? & ? & ?). order.
+Qed.
+Hint Resolve mapo_lt mapo_gt.
+
+Lemma mapo_bst m : Bst m -> Bst (mapo f m).
+Proof.
+functional induction (mapo f m); simpl; auto; intro H; inv Bst.
+- apply join_bst, create_bst; auto.
+- apply concat_bst; auto. apply between with x; auto.
+Qed.
+Hint Resolve mapo_bst.
+
+Ltac nonify e :=
+ replace e with (@None elt) by
+ (symmetry; rewrite not_find_iff; auto; intro; order).
+
+Definition obind {A B} (o:option A) (f:A->option B) :=
+ match o with Some a => f a | None => None end.
+
+Lemma mapo_find m x :
+ Bst m ->
+ exists y, X.eq y x /\
+ find x (mapo f m) = obind (find x m) (f y).
+Proof.
+functional induction (mapo f m); simpl; auto; intros B;
+ inv Bst.
+- now exists x.
+- rewrite join_find; auto.
+ + simpl. case X.compare_spec; simpl; intros.
+ * now exists x0.
+ * destruct IHt as (y' & ? & ?); auto.
+ exists y'; split; trivial.
+ * destruct IHt0 as (y' & ? & ?); auto.
+ exists y'; split; trivial.
+ + constructor; auto using mapo_lt, mapo_gt.
+- rewrite concat_find; auto.
+ + destruct IHt0 as (y' & ? & ->); auto.
+ destruct IHt as (y'' & ? & ->); auto.
+ case X.compare_spec; simpl; intros.
+ * nonify (find x r). nonify (find x l). simpl. now exists x0.
+ * nonify (find x r). now exists y''.
+ * nonify (find x l). exists y'. split; trivial.
+ destruct (find x r); simpl; trivial.
+ now destruct (f y' e).
+ + apply between with x0; auto.
+Qed.
+
+End Mapo.
+
+Section Gmerge.
+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 ->
+ exists y, X.eq y x /\
+ find x (mapl m) = obind (find x m) (fun d => f0 y (Some d) None).
+Hypothesis mapr_f0 : forall x m, Bst m ->
+ exists y, X.eq y x /\
+ find x (mapr m) = obind (find x m) (fun d => f0 y None (Some d)).
+
+Notation gmerge := (gmerge f mapl mapr).
+
+Lemma gmerge_in m m' y : Bst m -> Bst m' ->
+ y ∈ (gmerge m m') -> y ∈ m \/ y ∈ m'.
+Proof.
+ functional induction (gmerge m m'); intros B1 B2 H;
+ try factornode m2; inv Bst.
+ - right. apply find_in.
+ generalize (in_find (mapr_bst B2) H).
+ destruct (@mapr_f0 y m2) as (y' & ? & ->); trivial.
+ intros A B. rewrite B in A. now elim A.
+ - left. apply find_in.
+ generalize (in_find (mapl_bst B1) H).
+ destruct (@mapl_f0 y m2) as (y' & ? & ->); trivial.
+ intros A B. rewrite B in A. now elim A.
+ - rewrite join_in in *. revert IHt1 IHt0 H. cleansplit.
+ generalize (split_bst_l x1 B2) (split_bst_r x1 B2).
+ rewrite split_in_r, split_in_l; intuition_in.
+ - rewrite concat_in in *. revert IHt1 IHt0 H; cleansplit.
+ generalize (split_bst_l x1 B2) (split_bst_r x1 B2).
+ rewrite split_in_r, split_in_l; intuition_in.
+Qed.
+
+Lemma gmerge_lt m m' x : Bst m -> Bst m' ->
+ x >> m -> x >> m' -> x >> gmerge m m'.
+Proof.
+ intros. apply above. intros y Hy.
+ apply gmerge_in in Hy; intuition_in; order.
+Qed.
+
+Lemma gmerge_gt m m' x : Bst m -> Bst m' ->
+ x << m -> x << m' -> x << gmerge m m'.
+Proof.
+ intros. apply below. intros y Hy.
+ apply gmerge_in in Hy; intuition_in; order.
+Qed.
+Hint Resolve gmerge_lt gmerge_gt.
+Hint Resolve split_bst_l split_bst_r split_lt_l split_gt_r.
+
+Lemma gmerge_bst m m' : Bst m -> Bst m' -> Bst (gmerge m m').
+Proof.
+ functional induction (gmerge m m'); intros B1 B2; auto;
+ factornode m2; inv Bst;
+ (apply join_bst, create_bst || apply concat_bst);
+ revert IHt1 IHt0; cleansplit; intuition.
+ apply between with x1; auto.
+Qed.
+Hint Resolve gmerge_bst.
+
+Lemma oelse_none_r {A} (o:option A) : oelse o None = o.
+Proof. now destruct o. Qed.
+
+Ltac nonify e :=
+ let E := fresh "E" in
+ assert (E : e = None);
+ [ rewrite not_find_iff; auto; intro U;
+ try apply gmerge_in in U; intuition_in; order
+ | rewrite E; clear E ].
+
+Lemma gmerge_find m m' x : Bst m -> Bst m' ->
+ In x m \/ In x m' ->
+ exists y, X.eq y x /\
+ find x (gmerge m m') = f0 y (find x m) (find x m').
+Proof.
+ functional induction (gmerge m m'); intros B1 B2 H;
+ try factornode m2; inv Bst.
+ - destruct H; [ intuition_in | ].
+ destruct (@mapr_f0 x m2) as (y,(Hy,E)); trivial.
+ exists y; split; trivial.
+ rewrite E. simpl. apply in_find in H; trivial.
+ destruct (find x m2); simpl; intuition.
+ - destruct H; [ | intuition_in ].
+ destruct (@mapl_f0 x m2) as (y,(Hy,E)); trivial.
+ exists y; split; trivial.
+ rewrite E. simpl. apply in_find in H; trivial.
+ destruct (find x m2); simpl; intuition.
+ - generalize (split_bst_l x1 B2) (split_bst_r x1 B2).
+ rewrite (split_find x1 x B2).
+ rewrite e1 in *; simpl in *. intros.
+ rewrite join_find by (cleansplit; constructor; auto).
+ simpl. case X.compare_spec; intros.
+ + exists x1. split; auto. now rewrite <- e3, f0_f.
+ + apply IHt1; auto. clear IHt1 IHt0.
+ cleansplit; rewrite split_in_l; trivial.
+ intuition_in; order.
+ + apply IHt0; auto. clear IHt1 IHt0.
+ cleansplit; rewrite split_in_r; trivial.
+ intuition_in; order.
+ - generalize (split_bst_l x1 B2) (split_bst_r x1 B2).
+ rewrite (split_find x1 x B2).
+ pose proof (split_lt_l x1 B2).
+ pose proof (split_gt_r x1 B2).
+ rewrite e1 in *; simpl in *. intros.
+ rewrite concat_find by (try apply between with x1; auto).
+ case X.compare_spec; intros.
+ + clear IHt0 IHt1.
+ exists x1. split; auto. rewrite <- f0_f, e2.
+ nonify (find x (gmerge r1 r2')).
+ nonify (find x (gmerge l1 l2')). trivial.
+ + nonify (find x (gmerge r1 r2')).
+ simpl. apply IHt1; auto. clear IHt1 IHt0.
+ intuition_in; try order.
+ right. cleansplit. now apply split_in_l.
+ + nonify (find x (gmerge l1 l2')). simpl.
+ rewrite oelse_none_r.
+ apply IHt0; auto. clear IHt1 IHt0.
+ intuition_in; try order.
+ right. cleansplit. now apply split_in_r.
+Qed.
+
+End Gmerge.
+
+Section Merge.
+Variable elt elt' elt'' : Type.
+Variable f : key -> option elt -> option elt' -> option elt''.
+
+Lemma merge_bst m m' : Bst m -> Bst m' -> Bst (merge f m m').
+Proof.
+unfold merge; intros.
+apply gmerge_bst with f;
+ auto using mapo_bst, mapo_find.
+Qed.
+
+Lemma merge_spec1 m m' x : Bst m -> Bst m' ->
+ In x m \/ In x m' ->
+ exists y, X.eq y x /\
+ find x (merge f m m') = f y (find x m) (find x m').
+Proof.
+ unfold merge; intros.
+ edestruct (gmerge_find (f0:=f)) as (y,(Hy,E));
+ eauto using mapo_bst.
+ - reflexivity.
+ - intros. now apply mapo_find.
+ - intros. now apply mapo_find.
+Qed.
+
+Lemma merge_spec2 m m' x : Bst m -> Bst m' ->
+ In x (merge f m m') -> In x m \/ In x m'.
+Proof.
+unfold merge; intros.
+eapply gmerge_in with (f0:=f); try eassumption;
+ auto using mapo_bst, mapo_find.
+Qed.
+
+End Merge.
+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.
+
+ Record tree (elt:Type) :=
+ Mk {this :> Raw.tree elt; is_bst : Raw.Bst this}.
+
+ Definition t := tree.
+ 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 := Mk (empty_bst elt).
+ Definition is_empty m : bool := Raw.is_empty m.(this).
+ Definition add x e m : t elt := Mk (add_bst x e m.(is_bst)).
+ Definition remove x m : t elt := Mk (remove_bst x m.(is_bst)).
+ Definition mem x m : bool := Raw.mem x m.(this).
+ Definition find x m : option elt := Raw.find x m.(this).
+ Definition map f m : t elt' := Mk (map_bst f m.(is_bst)).
+ Definition mapi (f:key->elt->elt') m : t elt' :=
+ Mk (mapi_bst f m.(is_bst)).
+ Definition merge f m (m':t elt') : t elt'' :=
+ Mk (merge_bst f m.(is_bst) m'.(is_bst)).
+ Definition bindings m : list (key*elt) := Raw.bindings m.(this).
+ Definition cardinal m := Raw.cardinal m.(this).
+ Definition fold {A} (f:key->elt->A->A) m i := Raw.fold (A:=A) f m.(this) i.
+ Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this).
+
+ Definition MapsTo x e m : Prop := Raw.MapsTo x e m.(this).
+ Definition In x m : Prop := Raw.In0 x m.(this).
+
+ Definition 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.
+
+ Instance MapsTo_compat :
+ Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo.
+ Proof.
+ intros k k' Hk e e' He m m' Hm. unfold MapsTo; simpl.
+ now rewrite Hk, He, Hm.
+ Qed.
+
+ Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m.
+ Proof. apply find_spec. apply is_bst. Qed.
+
+ Lemma mem_spec m x : mem x m = true <-> In x m.
+ Proof.
+ unfold In, mem; rewrite In_alt. apply mem_spec. apply is_bst.
+ Qed.
+
+ Lemma empty_spec x : find x empty = None.
+ Proof. apply empty_spec. Qed.
+
+ Lemma is_empty_spec m : is_empty m = true <-> forall x, find x m = None.
+ Proof. apply is_empty_spec. Qed.
+
+ Lemma add_spec1 m x e : find x (add x e m) = Some e.
+ Proof. apply add_spec1. apply is_bst. Qed.
+ Lemma add_spec2 m x y e : ~ E.eq x y -> find y (add x e m) = find y m.
+ Proof. apply add_spec2. apply is_bst. Qed.
+
+ Lemma remove_spec1 m x : find x (remove x m) = None.
+ Proof. apply remove_spec1. apply is_bst. Qed.
+ Lemma remove_spec2 m x y : ~E.eq x y -> find y (remove x m) = find y m.
+ Proof. apply remove_spec2. apply is_bst. Qed.
+
+ Lemma bindings_spec1 m x e :
+ InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m.
+ Proof. apply bindings_mapsto. Qed.
+
+ Lemma bindings_spec2 m : sort lt_key (bindings m).
+ Proof. apply bindings_sort. apply is_bst. Qed.
+
+ Lemma bindings_spec2w m : NoDupA eq_key (bindings m).
+ Proof. apply bindings_nodup. apply is_bst. Qed.
+
+ Lemma fold_spec m {A} (i : A) (f : key -> elt -> A -> A) :
+ fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
+ Proof. apply fold_spec. apply is_bst. Qed.
+
+ Lemma cardinal_spec m : cardinal m = length (bindings m).
+ Proof. apply bindings_cardinal. 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 cmp m m' :
+ Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'.
+ Proof.
+ 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_spec m m' cmp :
+ equal cmp m m' = true <-> Equivb cmp m m'.
+ Proof. rewrite Equivb_Equivb. apply equal_Equivb; apply is_bst. Qed.
+
+ End Elt.
+
+ Lemma map_spec {elt elt'} (f:elt->elt') m x :
+ find x (map f m) = option_map f (find x m).
+ Proof. apply map_spec. Qed.
+
+ Lemma mapi_spec {elt elt'} (f:key->elt->elt') m x :
+ exists y:key, E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+ Proof. apply mapi_spec. Qed.
+
+ Lemma merge_spec1 {elt elt' elt''}
+ (f:key->option elt->option elt'->option elt'') m m' x :
+ In x m \/ In x m' ->
+ exists y:key, E.eq y x /\
+ find x (merge f m m') = f y (find x m) (find x m').
+ Proof.
+ unfold In. rewrite !In_alt. apply merge_spec1; apply is_bst.
+ Qed.
+
+ Lemma merge_spec2 {elt elt' elt''}
+ (f:key -> option elt->option elt'->option elt'') m m' x :
+ In x (merge f m m') -> In x m \/ In x m'.
+ Proof.
+ unfold In. rewrite !In_alt. apply merge_spec2; apply is_bst.
+ Qed.
+
+End IntMake.
+
+
+Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <:
+ Sord with Module Data := D
+ with Module MapS.E := X.
+
+ Module Data := D.
+ Module Import MapS := IntMake(I)(X).
+ Module LO := MMapList.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 bindings *)
+
+ 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 m1 m2 :=
+ compare_cont m1.(this) compare_end (R.cons m2 .(this) (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 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; case X.compare_spec; auto; try P.MX.order.
+ intros. right. split; auto. now symmetry.
+ Qed.
+ Hint Resolve cons_Cmp.
+
+ Lemma compare_end_Cmp e2 :
+ Cmp (compare_end e2) nil (P.flatten_e e2).
+ Proof.
+ destruct e2; simpl; auto.
+ Qed.
+
+ Lemma compare_more_Cmp x1 d1 cont x2 d2 r2 e2 l :
+ Cmp (cont (R.cons r2 e2)) l (R.bindings 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; case X.compare_spec; simpl;
+ try case D.compare_spec; simpl; auto;
+ case X.compare_spec; try P.MX.order; 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.bindings s1 ++ l) (P.flatten_e e2).
+ Proof.
+ induction s1 as [|l1 Hl1 x1 d1 r1 Hr1 h1] using P.tree_ind;
+ intros; auto.
+ rewrite <- P.bindings_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 m1 m2 :
+ Cmp (compare m1 m2) (bindings m1) (bindings m2).
+ Proof.
+ destruct m1 as (s1,H1), m2 as (s2,H2).
+ unfold compare, bindings; simpl.
+ rewrite <- (app_nil_r (R.bindings s1)).
+ replace (R.bindings 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.
+
+ Definition eq (m1 m2 : t) := LO.eq_list (bindings m1) (bindings m2).
+ Definition lt (m1 m2 : t) := LO.lt_list (bindings m1) (bindings m2).
+
+ Lemma compare_spec m1 m2 : CompSpec eq lt m1 m2 (compare m1 m2).
+ Proof.
+ assert (H := compare_Cmp m1 m2).
+ unfold Cmp in H.
+ destruct (compare m1 m2); auto.
+ Qed.
+
+ (* Proofs about [eq] and [lt] *)
+
+ Definition sbindings (m1 : t) :=
+ LO.MapS.Mk (P.bindings_sort m1.(is_bst)).
+
+ Definition seq (m1 m2 : t) := LO.eq (sbindings m1) (sbindings m2).
+ Definition slt (m1 m2 : t) := LO.lt (sbindings m1) (sbindings m2).
+
+ Lemma eq_seq : forall m1 m2, eq m1 m2 <-> seq m1 m2.
+ Proof.
+ unfold eq, seq, sbindings, bindings, LO.eq; intuition.
+ Qed.
+
+ Lemma lt_slt : forall m1 m2, lt m1 m2 <-> slt m1 m2.
+ Proof.
+ unfold lt, slt, sbindings, bindings, LO.lt; intuition.
+ Qed.
+
+ Lemma eq_spec m m' : eq m m' <-> Equivb cmp m m'.
+ Proof.
+ rewrite eq_seq; unfold seq.
+ rewrite Equivb_Equivb.
+ rewrite P.Equivb_bindings. apply LO.eq_spec.
+ Qed.
+
+ Instance eq_equiv : Equivalence eq.
+ Proof.
+ constructor; red; [intros x|intros x y| intros x y z];
+ rewrite !eq_seq; apply LO.eq_equiv.
+ Qed.
+
+ Instance lt_compat : Proper (eq ==> eq ==> iff) lt.
+ Proof.
+ intros m1 m2 H1 m1' m2' H2. rewrite !lt_slt. rewrite eq_seq in *.
+ now apply LO.lt_compat.
+ Qed.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+ constructor; red; [intros x; red|intros x y z];
+ rewrite !lt_slt; apply LO.lt_strorder.
+ 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/MMaps/MMapFacts.v b/theories/MMaps/MMapFacts.v
new file mode 100644
index 00000000..69066a7b
--- /dev/null
+++ b/theories/MMaps/MMapFacts.v
@@ -0,0 +1,2434 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(** * Finite maps library *)
+
+(** This functor derives additional facts from [MMapInterface.S]. These
+ facts are mainly the specifications of [MMapInterface.S] written using
+ different styles: equivalence and boolean equalities.
+*)
+
+Require Import Bool Equalities Orders OrdersFacts OrdersLists.
+Require Import Morphisms Permutation SetoidPermutation.
+Require Export MMapInterface.
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Lemma eq_bool_alt b b' : b=b' <-> (b=true <-> b'=true).
+Proof.
+ destruct b, b'; intuition.
+Qed.
+
+Lemma eq_option_alt {elt}(o o':option elt) :
+ o=o' <-> (forall e, o=Some e <-> o'=Some e).
+Proof.
+split; intros.
+- now subst.
+- destruct o, o'; rewrite ?H; auto.
+ symmetry; now apply H.
+Qed.
+
+Lemma option_map_some {A B}(f:A->B) o :
+ option_map f o <> None <-> o <> None.
+Proof.
+ destruct o; simpl. now split. split; now destruct 1.
+Qed.
+
+(** * Properties about weak maps *)
+
+Module WProperties_fun (E:DecidableType)(Import M:WSfun E).
+
+Definition Empty {elt}(m : t elt) := forall x e, ~MapsTo x e m.
+
+(** A few things about E.eq *)
+
+Lemma eq_refl x : E.eq x x. Proof. apply E.eq_equiv. Qed.
+Lemma eq_sym x y : E.eq x y -> E.eq y x. Proof. apply E.eq_equiv. Qed.
+Lemma eq_trans x y z : E.eq x y -> E.eq y z -> E.eq x z.
+Proof. apply E.eq_equiv. Qed.
+Hint Immediate eq_refl eq_sym : map.
+Hint Resolve eq_trans eq_equivalence E.eq_equiv : map.
+
+Definition eqb x y := if E.eq_dec x y then true else false.
+
+Lemma eqb_eq x y : eqb x y = true <-> E.eq x y.
+Proof.
+ unfold eqb; case E.eq_dec; now intuition.
+Qed.
+
+Lemma eqb_sym x y : eqb x y = eqb y x.
+Proof.
+ apply eq_bool_alt. rewrite !eqb_eq. split; apply E.eq_equiv.
+Qed.
+
+(** Initial results about MapsTo and In *)
+
+Lemma mapsto_fun {elt} m x (e e':elt) :
+ MapsTo x e m -> MapsTo x e' m -> e=e'.
+Proof.
+rewrite <- !find_spec. congruence.
+Qed.
+
+Lemma in_find {elt} (m : t elt) x : In x m <-> find x m <> None.
+Proof.
+ unfold In. split.
+ - intros (e,H). rewrite <-find_spec in H. congruence.
+ - destruct (find x m) as [e|] eqn:H.
+ + exists e. now apply find_spec.
+ + now destruct 1.
+Qed.
+
+Lemma not_in_find {elt} (m : t elt) x : ~In x m <-> find x m = None.
+Proof.
+ rewrite in_find. split; auto.
+ intros; destruct (find x m); trivial. now destruct H.
+Qed.
+
+Notation in_find_iff := in_find (only parsing).
+Notation not_find_in_iff := not_in_find (only parsing).
+
+(** * [Equal] is a setoid equality. *)
+
+Infix "==" := Equal (at level 30).
+
+Lemma Equal_refl {elt} (m : t elt) : m == m.
+Proof. red; reflexivity. Qed.
+
+Lemma Equal_sym {elt} (m m' : t elt) : m == m' -> m' == m.
+Proof. unfold Equal; auto. Qed.
+
+Lemma Equal_trans {elt} (m m' m'' : t elt) :
+ m == m' -> m' == m'' -> m == m''.
+Proof. unfold Equal; congruence. Qed.
+
+Instance Equal_equiv {elt} : Equivalence (@Equal elt).
+Proof.
+constructor; [exact Equal_refl | exact Equal_sym | exact Equal_trans].
+Qed.
+
+Arguments Equal {elt} m m'.
+
+Instance MapsTo_m {elt} :
+ Proper (E.eq==>Logic.eq==>Equal==>iff) (@MapsTo elt).
+Proof.
+intros k k' Hk e e' <- m m' Hm. rewrite <- Hk.
+now rewrite <- !find_spec, Hm.
+Qed.
+
+Instance In_m {elt} :
+ Proper (E.eq==>Equal==>iff) (@In elt).
+Proof.
+intros k k' Hk m m' Hm. unfold In.
+split; intros (e,H); exists e; revert H;
+ now rewrite Hk, <- !find_spec, Hm.
+Qed.
+
+Instance find_m {elt} : Proper (E.eq==>Equal==>Logic.eq) (@find elt).
+Proof.
+intros k k' Hk m m' <-.
+rewrite eq_option_alt. intros. now rewrite !find_spec, Hk.
+Qed.
+
+Instance mem_m {elt} : Proper (E.eq==>Equal==>Logic.eq) (@mem elt).
+Proof.
+intros k k' Hk m m' Hm. now rewrite eq_bool_alt, !mem_spec, Hk, Hm.
+Qed.
+
+Instance Empty_m {elt} : Proper (Equal==>iff) (@Empty elt).
+Proof.
+intros m m' Hm. unfold Empty. now setoid_rewrite Hm.
+Qed.
+
+Instance is_empty_m {elt} : Proper (Equal ==> Logic.eq) (@is_empty elt).
+Proof.
+intros m m' Hm. rewrite eq_bool_alt, !is_empty_spec.
+ now setoid_rewrite Hm.
+Qed.
+
+Instance add_m {elt} : Proper (E.eq==>Logic.eq==>Equal==>Equal) (@add elt).
+Proof.
+intros k k' Hk e e' <- m m' Hm y.
+destruct (E.eq_dec k y) as [H|H].
+- rewrite <-H, add_spec1. now rewrite Hk, add_spec1.
+- rewrite !add_spec2; trivial. now rewrite <- Hk.
+Qed.
+
+Instance remove_m {elt} : Proper (E.eq==>Equal==>Equal) (@remove elt).
+Proof.
+intros k k' Hk m m' Hm y.
+destruct (E.eq_dec k y) as [H|H].
+- rewrite <-H, remove_spec1. now rewrite Hk, remove_spec1.
+- rewrite !remove_spec2; trivial. now rewrite <- Hk.
+Qed.
+
+Instance map_m {elt elt'} :
+ Proper ((Logic.eq==>Logic.eq)==>Equal==>Equal) (@map elt elt').
+Proof.
+intros f f' Hf m m' Hm y. rewrite !map_spec, Hm.
+destruct (find y m'); simpl; trivial. f_equal. now apply Hf.
+Qed.
+
+Instance mapi_m {elt elt'} :
+ Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal) (@mapi elt elt').
+Proof.
+intros f f' Hf m m' Hm y.
+destruct (mapi_spec f m y) as (x,(Hx,->)).
+destruct (mapi_spec f' m' y) as (x',(Hx',->)).
+rewrite <- Hm. destruct (find y m); trivial. simpl.
+f_equal. apply Hf; trivial. now rewrite Hx, Hx'.
+Qed.
+
+Instance merge_m {elt elt' elt''} :
+ Proper ((E.eq==>Logic.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal==>Equal)
+ (@merge elt elt' elt'').
+Proof.
+intros f f' Hf m1 m1' Hm1 m2 m2' Hm2 y.
+destruct (find y m1) as [e1|] eqn:H1.
+- apply find_spec in H1.
+ assert (H : In y m1 \/ In y m2) by (left; now exists e1).
+ destruct (merge_spec1 f H) as (y1,(Hy1,->)).
+ rewrite Hm1,Hm2 in H.
+ destruct (merge_spec1 f' H) as (y2,(Hy2,->)).
+ rewrite <- Hm1, <- Hm2. apply Hf; trivial. now transitivity y.
+- destruct (find y m2) as [e2|] eqn:H2.
+ + apply find_spec in H2.
+ assert (H : In y m1 \/ In y m2) by (right; now exists e2).
+ destruct (merge_spec1 f H) as (y1,(Hy1,->)).
+ rewrite Hm1,Hm2 in H.
+ destruct (merge_spec1 f' H) as (y2,(Hy2,->)).
+ rewrite <- Hm1, <- Hm2. apply Hf; trivial. now transitivity y.
+ + apply not_in_find in H1. apply not_in_find in H2.
+ assert (H : ~In y (merge f m1 m2)).
+ { intro H. apply merge_spec2 in H. intuition. }
+ apply not_in_find in H. rewrite H.
+ symmetry. apply not_in_find. intro H'.
+ apply merge_spec2 in H'. rewrite <- Hm1, <- Hm2 in H'.
+ intuition.
+Qed.
+
+(* Later: compatibility for cardinal, fold, ... *)
+
+(** ** Earlier specifications (cf. FMaps) *)
+
+Section OldSpecs.
+Variable elt: Type.
+Implicit Type m: t elt.
+Implicit Type x y z: key.
+Implicit Type e: elt.
+
+Lemma MapsTo_1 m x y e : E.eq x y -> MapsTo x e m -> MapsTo y e m.
+Proof.
+ now intros ->.
+Qed.
+
+Lemma find_1 m x e : MapsTo x e m -> find x m = Some e.
+Proof. apply find_spec. Qed.
+
+Lemma find_2 m x e : find x m = Some e -> MapsTo x e m.
+Proof. apply find_spec. Qed.
+
+Lemma mem_1 m x : In x m -> mem x m = true.
+Proof. apply mem_spec. Qed.
+
+Lemma mem_2 m x : mem x m = true -> In x m.
+Proof. apply mem_spec. Qed.
+
+Lemma empty_1 : Empty (@empty elt).
+Proof.
+ intros x e. now rewrite <- find_spec, empty_spec.
+Qed.
+
+Lemma is_empty_1 m : Empty m -> is_empty m = true.
+Proof.
+ unfold Empty; rewrite is_empty_spec. setoid_rewrite <- find_spec.
+ intros H x. specialize (H x).
+ destruct (find x m) as [e|]; trivial.
+ now destruct (H e).
+Qed.
+
+Lemma is_empty_2 m : is_empty m = true -> Empty m.
+Proof.
+ rewrite is_empty_spec. intros H x e. now rewrite <- find_spec, H.
+Qed.
+
+Lemma add_1 m x y e : E.eq x y -> MapsTo y e (add x e m).
+Proof.
+ intros <-. rewrite <-find_spec. apply add_spec1.
+Qed.
+
+Lemma add_2 m x y e e' :
+ ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
+Proof.
+ intro. now rewrite <- !find_spec, add_spec2.
+Qed.
+
+Lemma add_3 m x y e e' :
+ ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
+Proof.
+ intro. rewrite <- !find_spec, add_spec2; trivial.
+Qed.
+
+Lemma remove_1 m x y : E.eq x y -> ~ In y (remove x m).
+Proof.
+ intros <-. apply not_in_find. apply remove_spec1.
+Qed.
+
+Lemma remove_2 m x y e :
+ ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
+Proof.
+ intro. now rewrite <- !find_spec, remove_spec2.
+Qed.
+
+Lemma remove_3bis m x y e :
+ find y (remove x m) = Some e -> find y m = Some e.
+Proof.
+ destruct (E.eq_dec x y) as [<-|H].
+ - now rewrite remove_spec1.
+ - now rewrite remove_spec2.
+Qed.
+
+Lemma remove_3 m x y e : MapsTo y e (remove x m) -> MapsTo y e m.
+Proof.
+ rewrite <-!find_spec. apply remove_3bis.
+Qed.
+
+Lemma bindings_1 m x e :
+ MapsTo x e m -> InA eq_key_elt (x,e) (bindings m).
+Proof. apply bindings_spec1. Qed.
+
+Lemma bindings_2 m x e :
+ InA eq_key_elt (x,e) (bindings m) -> MapsTo x e m.
+Proof. apply bindings_spec1. Qed.
+
+Lemma bindings_3w m : NoDupA eq_key (bindings m).
+Proof. apply bindings_spec2w. Qed.
+
+Lemma cardinal_1 m : cardinal m = length (bindings m).
+Proof. apply cardinal_spec. Qed.
+
+Lemma fold_1 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) (bindings m) i.
+Proof. apply fold_spec. Qed.
+
+Lemma equal_1 m m' cmp : Equivb cmp m m' -> equal cmp m m' = true.
+Proof. apply equal_spec. Qed.
+
+Lemma equal_2 m m' cmp : equal cmp m m' = true -> Equivb cmp m m'.
+Proof. apply equal_spec. Qed.
+
+End OldSpecs.
+
+Lemma map_1 {elt elt'}(m: t elt)(x:key)(e:elt)(f:elt->elt') :
+ MapsTo x e m -> MapsTo x (f e) (map f m).
+Proof.
+ rewrite <- !find_spec, map_spec. now intros ->.
+Qed.
+
+Lemma map_2 {elt elt'}(m: t elt)(x:key)(f:elt->elt') :
+ In x (map f m) -> In x m.
+Proof.
+ rewrite !in_find, map_spec. apply option_map_some.
+Qed.
+
+Lemma mapi_1 {elt elt'}(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.
+ destruct (mapi_spec f m x) as (y,(Hy,Eq)).
+ intro H. exists y; split; trivial.
+ rewrite <-find_spec in *. now rewrite Eq, H.
+Qed.
+
+Lemma mapi_2 {elt elt'}(m: t elt)(x:key)(f:key->elt->elt') :
+ In x (mapi f m) -> In x m.
+Proof.
+ destruct (mapi_spec f m x) as (y,(Hy,Eq)).
+ rewrite !in_find. intro H; contradict H. now rewrite Eq, H.
+Qed.
+
+(** The ancestor [map2] of the current [merge] was dealing with functions
+ on datas only, not on keys. *)
+
+Definition map2 {elt elt' elt''} (f:option elt->option elt'->option elt'')
+ := merge (fun _ => f).
+
+Lemma map2_1 {elt elt' elt''}(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.
+ now destruct (merge_spec1 (fun _ => f) H) as (y,(_,->)).
+Qed.
+
+Lemma map2_2 {elt elt' elt''}(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. apply merge_spec2. Qed.
+
+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.
+
+(** ** Specifications written using equivalences *)
+
+Section IffSpec.
+Variable elt: Type.
+Implicit Type m: t elt.
+Implicit Type x y z: key.
+Implicit Type e: elt.
+
+Lemma in_iff m x y : E.eq x y -> (In x m <-> In y m).
+Proof. now intros ->. Qed.
+
+Lemma mapsto_iff m x y e : E.eq x y -> (MapsTo x e m <-> MapsTo y e m).
+Proof. now intros ->. Qed.
+
+Lemma mem_in_iff m x : In x m <-> mem x m = true.
+Proof. symmetry. apply mem_spec. Qed.
+
+Lemma not_mem_in_iff m x : ~In x m <-> mem x m = false.
+Proof.
+rewrite mem_in_iff; destruct (mem x m); intuition.
+Qed.
+
+Lemma mem_find m x : mem x m = true <-> find x m <> None.
+Proof.
+ rewrite <- mem_in_iff. apply in_find.
+Qed.
+
+Lemma not_mem_find m x : mem x m = false <-> find x m = None.
+Proof.
+ rewrite <- not_mem_in_iff. apply not_in_find.
+Qed.
+
+Lemma In_dec m x : { In x m } + { ~ In x m }.
+Proof.
+ generalize (mem_in_iff m x).
+ destruct (mem x m); [left|right]; intuition.
+Qed.
+
+Lemma find_mapsto_iff m x e : MapsTo x e m <-> find x m = Some e.
+Proof. symmetry. apply find_spec. Qed.
+
+Lemma equal_iff m m' cmp : Equivb cmp m m' <-> equal cmp m m' = true.
+Proof. symmetry. apply equal_spec. Qed.
+
+Lemma empty_mapsto_iff x e : MapsTo x e empty <-> False.
+Proof.
+rewrite <- find_spec, empty_spec. now split.
+Qed.
+
+Lemma not_in_empty x : ~In x (@empty elt).
+Proof.
+intros (e,H). revert H. apply empty_mapsto_iff.
+Qed.
+
+Lemma empty_in_iff x : In x (@empty elt) <-> False.
+Proof.
+split; [ apply not_in_empty | destruct 1 ].
+Qed.
+
+Lemma is_empty_iff m : Empty m <-> is_empty m = true.
+Proof. split; [apply is_empty_1 | apply is_empty_2 ]. Qed.
+
+Lemma add_mapsto_iff 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.
+split.
+- intros H. destruct (E.eq_dec x y); [left|right]; split; trivial.
+ + symmetry. apply (mapsto_fun H); auto with map.
+ + now apply add_3 with x e.
+- destruct 1 as [(H,H')|(H,H')]; subst; auto with map.
+Qed.
+
+Lemma add_mapsto_new m x y e e' : ~In x m ->
+ MapsTo y e' (add x e m) <-> (E.eq x y /\ e=e') \/ MapsTo y e' m.
+Proof.
+ intros.
+ rewrite add_mapsto_iff. intuition.
+ right; split; trivial. contradict H. exists e'. now rewrite H.
+Qed.
+
+Lemma in_add m x y e : In y m -> In y (add x e m).
+Proof.
+ destruct (E.eq_dec x y) as [<-|H'].
+ - now rewrite !in_find, add_spec1.
+ - now rewrite !in_find, add_spec2.
+Qed.
+
+Lemma add_in_iff m x y e : In y (add x e m) <-> E.eq x y \/ In y m.
+Proof.
+split.
+- intros H. destruct (E.eq_dec x y); [now left|right].
+ rewrite in_find, add_spec2 in H; trivial. now apply in_find.
+- intros [<-|H].
+ + exists e. now apply add_1.
+ + now apply in_add.
+Qed.
+
+Lemma add_neq_mapsto_iff 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 m x y e :
+ ~ E.eq x y -> (In y (add x e m) <-> In y m).
+Proof.
+split; intros (e',H0); exists e'.
+- now apply add_3 with x e.
+- now apply add_2.
+Qed.
+
+Lemma remove_mapsto_iff m x y e :
+ MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m.
+Proof.
+split; [split|destruct 1].
+- intro E. revert H. now rewrite <-E, <- find_spec, remove_spec1.
+- now apply remove_3 with x.
+- now apply remove_2.
+Qed.
+
+Lemma remove_in_iff m x y : In y (remove x m) <-> ~E.eq x y /\ In y m.
+Proof.
+unfold In; split; [ intros (e,H) | intros (E,(e,H)) ].
+- apply remove_mapsto_iff in H. destruct H; split; trivial.
+ now exists e.
+- exists e. now apply remove_2.
+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'.
+- now apply remove_3 with x.
+- now apply remove_2.
+Qed.
+
+Lemma bindings_mapsto_iff m x e :
+ MapsTo x e m <-> InA eq_key_elt (x,e) (bindings m).
+Proof. symmetry. apply bindings_spec1. Qed.
+
+Lemma bindings_in_iff m x :
+ In x m <-> exists e, InA eq_key_elt (x,e) (bindings m).
+Proof.
+unfold In; split; intros (e,H); exists e; now apply bindings_spec1.
+Qed.
+
+End IffSpec.
+
+Lemma map_mapsto_iff {elt elt'} m x b (f : elt -> elt') :
+ MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m.
+Proof.
+rewrite <-find_spec, map_spec. setoid_rewrite <- find_spec.
+destruct (find x m); simpl; split.
+- injection 1. now exists e.
+- intros (a,(->,H)). now injection H as ->.
+- discriminate.
+- intros (a,(_,H)); discriminate.
+Qed.
+
+Lemma map_in_iff {elt elt'} m x (f : elt -> elt') :
+ In x (map f m) <-> In x m.
+Proof.
+rewrite !in_find, map_spec. apply option_map_some.
+Qed.
+
+Lemma mapi_in_iff {elt elt'} m x (f:key->elt->elt') :
+ In x (mapi f m) <-> In x m.
+Proof.
+rewrite !in_find. destruct (mapi_spec f m x) as (y,(_,->)).
+apply option_map_some.
+Qed.
+
+(** Unfortunately, we don't have simple equivalences for [mapi]
+ and [MapsTo]. The only correct one needs compatibility of [f]. *)
+
+Lemma mapi_inv {elt elt'} 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.
+rewrite <- find_spec. setoid_rewrite <- find_spec.
+destruct (mapi_spec f m x) as (y,(E,->)).
+destruct (find x m); simpl.
+- injection 1 as <-. now exists e, y.
+- discriminate.
+Qed.
+
+Lemma mapi_spec' {elt elt'} (f:key->elt->elt') :
+ Proper (E.eq==>Logic.eq==>Logic.eq) f ->
+ forall m x,
+ find x (mapi f m) = option_map (f x) (find x m).
+Proof.
+ intros. destruct (mapi_spec f m x) as (y,(Hy,->)).
+ destruct (find x m); simpl; trivial.
+ now rewrite Hy.
+Qed.
+
+Lemma mapi_1bis {elt elt'} m x e (f:key->elt->elt') :
+ Proper (E.eq==>Logic.eq==>Logic.eq) f ->
+ MapsTo x e m -> MapsTo x (f x e) (mapi f m).
+Proof.
+intros. destruct (mapi_1 f H0) as (y,(->,H2)). trivial.
+Qed.
+
+Lemma mapi_mapsto_iff {elt elt'} m x b (f:key->elt->elt') :
+ Proper (E.eq==>Logic.eq==>Logic.eq) f ->
+ (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m).
+Proof.
+rewrite <-find_spec. setoid_rewrite <-find_spec.
+intros Pr. rewrite mapi_spec' by trivial.
+destruct (find x m); simpl; split.
+- injection 1 as <-. now exists e.
+- intros (a,(->,H)). now injection H as <-.
+- discriminate.
+- intros (a,(_,H)). discriminate.
+Qed.
+
+(** Things are even worse for [merge] : we don't try to state any
+ equivalence, see instead boolean results below. *)
+
+(** 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 {elt}(m:t elt)(x:key) :
+ mem x m = if find x m then true else false.
+Proof.
+apply eq_bool_alt. rewrite mem_find. destruct (find x m).
+- now split.
+- split; (discriminate || now destruct 1).
+Qed.
+
+Variable elt elt' elt'' : Type.
+Implicit Types m : t elt.
+Implicit Types x y z : key.
+Implicit Types e : elt.
+
+Lemma mem_b m x y : E.eq x y -> mem x m = mem y m.
+Proof. now intros ->. Qed.
+
+Lemma find_o m x y : E.eq x y -> find x m = find y m.
+Proof. now intros ->. Qed.
+
+Lemma empty_o x : find x (@empty elt) = None.
+Proof. apply empty_spec. Qed.
+
+Lemma empty_a x : mem x (@empty elt) = false.
+Proof. apply not_mem_find. apply empty_spec. Qed.
+
+Lemma add_eq_o m x y e :
+ E.eq x y -> find y (add x e m) = Some e.
+Proof.
+ intros <-. apply add_spec1.
+Qed.
+
+Lemma add_neq_o m x y e :
+ ~ E.eq x y -> find y (add x e m) = find y m.
+Proof. apply add_spec2. Qed.
+Hint Resolve add_neq_o : map.
+
+Lemma add_o m x y e :
+ find y (add x e m) = if E.eq_dec x y then Some e else find y m.
+Proof.
+destruct (E.eq_dec x y); auto with map.
+Qed.
+
+Lemma add_eq_b m x y e :
+ E.eq x y -> mem y (add x e m) = true.
+Proof.
+intros <-. apply mem_spec, add_in_iff. now left.
+Qed.
+
+Lemma add_neq_b m x y e :
+ ~E.eq x y -> mem y (add x e m) = mem y m.
+Proof.
+intros. now rewrite !mem_find_b, add_neq_o.
+Qed.
+
+Lemma add_b m x y e :
+ mem y (add x e m) = eqb x y || mem y m.
+Proof.
+rewrite !mem_find_b, add_o. unfold eqb.
+now destruct (E.eq_dec x y).
+Qed.
+
+Lemma remove_eq_o m x y :
+ E.eq x y -> find y (remove x m) = None.
+Proof. intros ->. apply remove_spec1. Qed.
+
+Lemma remove_neq_o m x y :
+ ~ E.eq x y -> find y (remove x m) = find y m.
+Proof. apply remove_spec2. Qed.
+
+Hint Resolve remove_eq_o remove_neq_o : map.
+
+Lemma remove_o m x y :
+ find y (remove x m) = if E.eq_dec x y then None else find y m.
+Proof.
+destruct (E.eq_dec x y); auto with map.
+Qed.
+
+Lemma remove_eq_b m x y :
+ E.eq x y -> mem y (remove x m) = false.
+Proof.
+intros <-. now rewrite mem_find_b, remove_eq_o.
+Qed.
+
+Lemma remove_neq_b m x y :
+ ~ E.eq x y -> mem y (remove x m) = mem y m.
+Proof.
+intros. now rewrite !mem_find_b, remove_neq_o.
+Qed.
+
+Lemma remove_b m x y :
+ mem y (remove x m) = negb (eqb x y) && mem y m.
+Proof.
+rewrite !mem_find_b, remove_o; unfold eqb.
+now destruct (E.eq_dec x y).
+Qed.
+
+Lemma map_o m x (f:elt->elt') :
+ find x (map f m) = option_map f (find x m).
+Proof. apply map_spec. Qed.
+
+Lemma map_b m x (f:elt->elt') :
+ mem x (map f m) = mem x m.
+Proof.
+rewrite !mem_find_b, map_o. now destruct (find x m).
+Qed.
+
+Lemma mapi_b m x (f:key->elt->elt') :
+ mem x (mapi f m) = mem x m.
+Proof.
+apply eq_bool_alt; rewrite !mem_spec. apply mapi_in_iff.
+Qed.
+
+Lemma mapi_o m x (f:key->elt->elt') :
+ Proper (E.eq==>Logic.eq==>Logic.eq) f ->
+ find x (mapi f m) = option_map (f x) (find x m).
+Proof. intros; now apply mapi_spec'. Qed.
+
+Lemma merge_spec1' (f:key->option elt->option elt'->option elt'') :
+ Proper (E.eq==>Logic.eq==>Logic.eq==>Logic.eq) f ->
+ forall (m:t elt)(m':t elt') x,
+ In x m \/ In x m' ->
+ find x (merge f m m') = f x (find x m) (find x m').
+Proof.
+ intros Hf m m' x H.
+ now destruct (merge_spec1 f H) as (y,(->,->)).
+Qed.
+
+Lemma merge_spec1_none (f:key->option elt->option elt'->option elt'') :
+ (forall x, f x None None = None) ->
+ forall (m: t elt)(m': t elt') x,
+ exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m').
+Proof.
+intros Hf m m' x.
+destruct (find x m) as [e|] eqn:Hm.
+- assert (H : In x m \/ In x m') by (left; exists e; now apply find_spec).
+ destruct (merge_spec1 f H) as (y,(Hy,->)).
+ exists y; split; trivial. now rewrite Hm.
+- destruct (find x m') as [e|] eqn:Hm'.
+ + assert (H : In x m \/ In x m') by (right; exists e; now apply find_spec).
+ destruct (merge_spec1 f H) as (y,(Hy,->)).
+ exists y; split; trivial. now rewrite Hm, Hm'.
+ + exists x. split. reflexivity. rewrite Hf.
+ apply not_in_find. intro H.
+ apply merge_spec2 in H. apply not_in_find in Hm. apply not_in_find in Hm'.
+ intuition.
+Qed.
+
+Lemma merge_spec1'_none (f:key->option elt->option elt'->option elt'') :
+ Proper (E.eq==>Logic.eq==>Logic.eq==>Logic.eq) f ->
+ (forall x, f x None None = None) ->
+ forall (m: t elt)(m': t elt') x,
+ find x (merge f m m') = f x (find x m) (find x m').
+Proof.
+ intros Hf Hf' m m' x.
+ now destruct (merge_spec1_none Hf' m m' x) as (y,(->,->)).
+Qed.
+
+Lemma bindings_o : forall m x,
+ find x m = findA (eqb x) (bindings m).
+Proof.
+intros. rewrite eq_option_alt. intro e.
+rewrite <- find_mapsto_iff, bindings_mapsto_iff.
+unfold eqb.
+rewrite <- findA_NoDupA; dintuition; try apply bindings_3w; eauto.
+Qed.
+
+Lemma bindings_b : forall m x,
+ mem x m = existsb (fun p => eqb x (fst p)) (bindings m).
+Proof.
+intros.
+apply eq_bool_alt.
+rewrite mem_spec, bindings_in_iff, existsb_exists.
+split.
+- intros (e,H).
+ rewrite InA_alt in H.
+ destruct H as ((k,e'),((H1,H2),H')); simpl in *; subst e'.
+ exists (k, e); split; trivial. simpl. now apply eqb_eq.
+- intros ((k,e),(H,H')); simpl in *. apply eqb_eq in H'.
+ exists e. rewrite InA_alt. exists (k,e). now repeat split.
+Qed.
+
+End BoolSpec.
+
+Section Equalities.
+Variable elt:Type.
+
+(** A few basic equalities *)
+
+Lemma eq_empty (m: t elt) : m == empty <-> is_empty m = true.
+Proof.
+ unfold Equal. rewrite is_empty_spec. now setoid_rewrite empty_spec.
+Qed.
+
+Lemma add_id (m: t elt) x e : add x e m == m <-> find x m = Some e.
+Proof.
+ split.
+ - intros H. rewrite <- (H x). apply add_spec1.
+ - intros H y. rewrite !add_o. now destruct E.eq_dec as [<-|E].
+Qed.
+
+Lemma add_add_1 (m: t elt) x e :
+ add x e (add x e m) == add x e m.
+Proof.
+ intros y. rewrite !add_o. destruct E.eq_dec; auto.
+Qed.
+
+Lemma add_add_2 (m: t elt) x x' e e' :
+ ~E.eq x x' -> add x e (add x' e' m) == add x' e' (add x e m).
+Proof.
+ intros H y. rewrite !add_o.
+ do 2 destruct E.eq_dec; auto.
+ elim H. now transitivity y.
+Qed.
+
+Lemma remove_id (m: t elt) x : remove x m == m <-> ~In x m.
+Proof.
+ rewrite not_in_find. split.
+ - intros H. rewrite <- (H x). apply remove_spec1.
+ - intros H y. rewrite !remove_o. now destruct E.eq_dec as [<-|E].
+Qed.
+
+Lemma remove_remove_1 (m: t elt) x :
+ remove x (remove x m) == remove x m.
+Proof.
+ intros y. rewrite !remove_o. destruct E.eq_dec; auto.
+Qed.
+
+Lemma remove_remove_2 (m: t elt) x x' :
+ remove x (remove x' m) == remove x' (remove x m).
+Proof.
+ intros y. rewrite !remove_o. do 2 destruct E.eq_dec; auto.
+Qed.
+
+Lemma remove_add_1 (m: t elt) x e :
+ remove x (add x e m) == remove x m.
+Proof.
+ intro y. rewrite !remove_o, !add_o. now destruct E.eq_dec.
+Qed.
+
+Lemma remove_add_2 (m: t elt) x x' e :
+ ~E.eq x x' -> remove x' (add x e m) == add x e (remove x' m).
+Proof.
+ intros H y. rewrite !remove_o, !add_o.
+ do 2 destruct E.eq_dec; auto.
+ - elim H; now transitivity y.
+ - symmetry. now apply remove_eq_o.
+ - symmetry. now apply remove_neq_o.
+Qed.
+
+Lemma add_remove_1 (m: t elt) x e :
+ add x e (remove x m) == add x e m.
+Proof.
+ intro y. rewrite !add_o, !remove_o. now destruct E.eq_dec.
+Qed.
+
+(** Another characterisation of [Equal] *)
+
+Lemma Equal_mapsto_iff : forall m1 m2 : t elt,
+ 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),
+ 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), 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), 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.
+
+(** * Results about [fold], [bindings], induction principles... *)
+
+Section Elt.
+ Variable elt:Type.
+
+ Definition Add x (e:elt) m m' := m' == (add x e m).
+
+ Notation eqke := (@eq_key_elt elt).
+ Notation eqk := (@eq_key elt).
+
+ Instance eqk_equiv : Equivalence eqk.
+ Proof. unfold eq_key. destruct E.eq_equiv. constructor; eauto. Qed.
+
+ Instance eqke_equiv : Equivalence eqke.
+ Proof.
+ unfold eq_key_elt; split; repeat red; intuition; simpl in *;
+ etransitivity; eauto.
+ Qed.
+
+ (** Complements about InA, NoDupA and findA *)
+
+ Lemma InA_eqke_eqk k k' e e' l :
+ E.eq k k' -> InA eqke (k,e) l -> InA eqk (k',e') l.
+ Proof.
+ intros Hk. rewrite 2 InA_alt.
+ intros ((k'',e'') & (Hk'',He'') & H); simpl in *; subst e''.
+ exists (k'',e); split; auto. red; simpl. now transitivity k.
+ Qed.
+
+ Lemma NoDupA_incl {A} (R R':relation A) :
+ (forall x y, R x y -> R' x y) ->
+ forall l, NoDupA R' l -> NoDupA R l.
+ Proof.
+ intros Incl.
+ induction 1 as [ | a l E _ IH ]; constructor; auto.
+ contradict E. revert E. rewrite 2 InA_alt. firstorder.
+ Qed.
+
+ Lemma NoDupA_eqk_eqke l : NoDupA eqk l -> NoDupA eqke l.
+ Proof.
+ apply NoDupA_incl. now destruct 1.
+ Qed.
+
+ Lemma findA_rev l k : NoDupA eqk l ->
+ findA (eqb k) l = findA (eqb k) (rev l).
+ Proof.
+ intros H. apply eq_option_alt. intros e. unfold eqb.
+ rewrite <- !findA_NoDupA, InA_rev; eauto with map. reflexivity.
+ change (NoDupA eqk (rev l)). apply NoDupA_rev; auto using eqk_equiv.
+ Qed.
+
+ (** * Bindings *)
+
+ Lemma bindings_Empty (m:t elt) : Empty m <-> bindings m = nil.
+ Proof.
+ unfold Empty. split; intros H.
+ - assert (H' : forall a, ~ List.In a (bindings m)).
+ { intros (k,e) H'. apply (H k e).
+ rewrite bindings_mapsto_iff, InA_alt.
+ exists (k,e); repeat split; auto with map. }
+ destruct (bindings m) as [|p l]; trivial.
+ destruct (H' p); simpl; auto.
+ - intros x e. rewrite bindings_mapsto_iff, InA_alt.
+ rewrite H. now intros (y,(E,H')).
+ Qed.
+
+ Lemma bindings_empty : bindings (@empty elt) = nil.
+ Proof.
+ rewrite <-bindings_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 := bindings.
+
+ 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 (E.eq_dec k k'); [left|right]; split; auto with map.
+ 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, eqb_sym. unfold eqb; now destruct E.eq_dec.
+ 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 <- bindings_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, bindings_o; auto.
+ apply bindings_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 (bindings 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 (bindings 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, bindings_mapsto_iff; auto with *. }
+ assert (Hdup : NoDupA eqk l).
+ { unfold l. apply NoDupA_rev; try red; unfold eq_key ; eauto with *.
+ apply bindings_3w. }
+ assert (Hsame : forall k, find k m = findA (eqb k) l).
+ { intros k. unfold l. rewrite bindings_o, findA_rev; auto.
+ apply bindings_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 with map.
+ + inversion_clear Hdup. contradict H. destruct H as (e',He').
+ apply InA_eqke_eqk with k e'; auto with map.
+ rewrite <- of_list_1; auto.
+ + intro k'. rewrite Hsame, add_o, of_list_1b. simpl.
+ rewrite eqb_sym. unfold eqb. now destruct E.eq_dec.
+ inversion_clear Hdup; auto with map.
+ + 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 (bindings 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)).
+ { intros; apply Rstep; auto.
+ rewrite bindings_mapsto_iff, <- InA_rev; auto with map. }
+ clearbody l; clear Rstep m.
+ induction l; simpl; auto.
+ apply Rstep'; auto.
+ destruct a; simpl; rewrite InA_cons; left; red; auto with map.
+ 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).
+
+ Lemma fold_Empty (f:key->elt->A->A) :
+ 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.
+
+ Lemma fold_init (f:key->elt->A->A) :
+ Proper (E.eq==>eq==>eqA==>eqA) f ->
+ forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i').
+ Proof.
+ intros Hf m i i' Hi. apply fold_rel with (R:=eqA); auto.
+ intros. now apply Hf.
+ Qed.
+
+ (** Transpositions of f (a.k.a diamond property).
+ Could we swap two sequential calls to f, i.e. do we have:
+
+ f k e (f k' e' a) == f k' e' (f k e a)
+
+ First, we do no need this equation for all keys, but only
+ when k and k' aren't equal, as suggested by Pierre Castéran.
+ Think for instance of [f] being [M.add] : in general, we don't have
+ [M.add k e (M.add k e' m) == 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.
+ NB: without this condition, this condition would be
+ [SetoidList.transpose2].
+
+ Secondly, instead of the equation above, we now use a statement
+ with more basic equalities, allowing to prove [fold_commutes] even
+ when [f] isn't a morphism.
+ NB: When [f] is a morphism, [Diamond f] gives back the equation above.
+*)
+
+ Definition Diamond (f:key->elt->A->A) :=
+ forall k k' e e' a b b', ~E.eq k k' ->
+ eqA (f k e a) b -> eqA (f k' e' a) b' -> eqA (f k e b') (f k' e' b).
+
+ Lemma fold_commutes (f:key->elt->A->A) :
+ Diamond f ->
+ 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 Hf i m k e H.
+ apply fold_rel with (R:= fun a b => eqA a (f k e b)); auto.
+ - reflexivity.
+ - intros k' e' b a Hm E.
+ apply Hf with a; try easy.
+ contradict H; rewrite <- H. now exists e'.
+ Qed.
+
+ Hint Resolve NoDupA_eqk_eqke NoDupA_rev bindings_3w : map.
+
+ Lemma fold_Proper (f:key->elt->A->A) :
+ Proper (E.eq==>eq==>eqA==>eqA) f ->
+ Diamond f ->
+ Proper (Equal==>eqA==>eqA) (fold f).
+ Proof.
+ intros Hf Hf' m1 m2 Hm i j Hi.
+ rewrite 2 fold_spec_right.
+ assert (NoDupA eqk (rev (bindings m1))) by (auto with * ).
+ assert (NoDupA eqk (rev (bindings 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 *. now apply Hf.
+ - unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto with map.
+ - intros (k,e) (k',e') z z' h h'; unfold eq_key, uncurry;simpl; auto.
+ rewrite h'. eapply Hf'; now eauto.
+ - rewrite <- NoDupA_altdef; auto.
+ - intros (k,e).
+ rewrite 2 InA_rev, <- 2 bindings_mapsto_iff, 2 find_mapsto_iff, Hm;
+ auto with *.
+ Qed.
+
+ Lemma fold_Equal (f:key->elt->A->A) :
+ Proper (E.eq==>eq==>eqA==>eqA) f ->
+ Diamond f ->
+ forall m1 m2 i,
+ Equal m1 m2 ->
+ eqA (fold f m1 i) (fold f m2 i).
+ Proof.
+ intros. now apply fold_Proper.
+ Qed.
+
+ Lemma fold_Add (f:key->elt->A->A) :
+ Proper (E.eq==>eq==>eqA==>eqA) f ->
+ Diamond f ->
+ 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 Hf Hf' m1 m2 k e i Hm1 Hm2.
+ rewrite 2 fold_spec_right.
+ set (f':=uncurry f).
+ change (f k e (fold_right f' i (rev (bindings m1))))
+ with (f' (k,e) (fold_right f' i (rev (bindings m1)))).
+ assert (NoDupA eqk (rev (bindings m1))) by (auto with * ).
+ assert (NoDupA eqk (rev (bindings m2))) by (auto with * ).
+ apply fold_right_add_restr with
+ (R:=complement eqk)(eqA:=eqke); auto with *.
+ - intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. now apply Hf.
+ - unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto with map.
+ - intros (k1,e1) (k2,e2) z1 z2; unfold eq_key, f', uncurry; simpl.
+ eapply Hf'; now eauto.
+ - rewrite <- NoDupA_altdef; auto.
+ - rewrite InA_rev, <- bindings_mapsto_iff by (auto with * ). firstorder.
+ - intros (a,b).
+ rewrite InA_cons, 2 InA_rev, <- 2 bindings_mapsto_iff,
+ 2 find_mapsto_iff by (auto with * ).
+ unfold eq_key_elt; simpl.
+ rewrite Hm2, !find_spec, add_mapsto_new; intuition.
+ Qed.
+
+ Lemma fold_add (f:key->elt->A->A) :
+ Proper (E.eq==>eq==>eqA==>eqA) f ->
+ Diamond f ->
+ 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. now apply fold_Add.
+ Qed.
+
+ End Fold_More.
+
+ (** * Cardinal *)
+
+ Lemma cardinal_fold (m : t elt) :
+ cardinal m = fold (fun _ _ => S) m 0.
+ Proof.
+ 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, bindings_Empty.
+ destruct (bindings m); intuition; discriminate.
+ Qed.
+
+ Lemma Equal_cardinal (m m' : t elt) :
+ Equal m m' -> cardinal m = cardinal m'.
+ Proof.
+ intro. rewrite 2 cardinal_fold.
+ apply fold_Equal with (eqA:=eq); try congruence; auto with map.
+ Qed.
+
+ Lemma cardinal_0 (m : t elt) : Empty m -> cardinal m = 0.
+ Proof.
+ intros; rewrite <- cardinal_Empty; auto.
+ Qed.
+
+ Lemma cardinal_S m m' x e :
+ ~ In x m -> Add x e m m' -> cardinal m' = S (cardinal m).
+ Proof.
+ intros. rewrite 2 cardinal_fold.
+ change S with ((fun _ _ => S) x e).
+ apply fold_Add with (eqA:=eq); try congruence; auto with map.
+ 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_spec in *.
+ generalize (bindings_mapsto_iff m).
+ destruct (bindings m); try discriminate.
+ exists p; auto.
+ rewrite H0; destruct p; simpl; auto.
+ constructor; red; auto with map.
+ Qed.
+
+ Lemma cardinal_inv_2b :
+ forall m, cardinal m <> 0 -> { p : key*elt | MapsTo (fst p) (snd p) m }.
+ Proof.
+ intros.
+ generalize (@cardinal_inv_2 m); destruct cardinal.
+ elim H;auto.
+ eauto.
+ Qed.
+
+ Lemma not_empty_mapsto (m : t elt) :
+ ~Empty m -> exists k e, MapsTo k e m.
+ Proof.
+ intro.
+ destruct (@cardinal_inv_2b m) as ((k,e),H').
+ contradict H. now apply cardinal_inv_1.
+ exists k; now exists e.
+ Qed.
+
+ Lemma not_empty_in (m:t elt) :
+ ~Empty m -> exists k, In k m.
+ Proof.
+ intro. destruct (not_empty_mapsto H) as (k,Hk).
+ now exists k.
+ 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.
+
+ (** Properties of these abbreviations *)
+
+ Lemma filter_iff (f : key -> elt -> bool) :
+ Proper (E.eq==>eq==>eq) f ->
+ 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).
+ intros Hf 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.
+ rewrite add_mapsto_new by trivial.
+ case_eq (f k e); intros Hfke; simpl;
+ rewrite ?add_mapsto_iff, IH; clear IH; intuition.
+ + rewrite <- Hfke; apply Hf; auto with map.
+ + right. repeat split; trivial. contradict Hn. rewrite Hn. now exists e'.
+ + assert (f k e = f k' e') by (apply Hf; auto). congruence.
+ Qed.
+
+ Lemma for_all_filter f m :
+ for_all f m = is_empty (filter (fun k e => negb (f k e)) m).
+ Proof.
+ unfold for_all, filter.
+ eapply fold_rel with (R:=fun x y => x = is_empty y).
+ - symmetry. apply is_empty_iff. apply empty_1.
+ - intros; subst. destruct (f k e); simpl; trivial.
+ symmetry. apply not_true_is_false. rewrite is_empty_spec.
+ intros H'. specialize (H' k). now rewrite add_spec1 in H'.
+ Qed.
+
+ Lemma exists_filter f m :
+ exists_ f m = negb (is_empty (filter f m)).
+ Proof.
+ unfold for_all, filter.
+ eapply fold_rel with (R:=fun x y => x = negb (is_empty y)).
+ - symmetry. rewrite negb_false_iff. apply is_empty_iff. apply empty_1.
+ - intros; subst. destruct (f k e); simpl; trivial.
+ symmetry. rewrite negb_true_iff. apply not_true_is_false.
+ rewrite is_empty_spec.
+ intros H'. specialize (H' k). now rewrite add_spec1 in H'.
+ Qed.
+
+ Lemma for_all_iff f m :
+ Proper (E.eq==>eq==>eq) f ->
+ (for_all f m = true <-> (forall k e, MapsTo k e m -> f k e = true)).
+ Proof.
+ intros Hf.
+ rewrite for_all_filter.
+ rewrite <- is_empty_iff. unfold Empty.
+ split; intros H k e; specialize (H k e);
+ rewrite filter_iff in * by solve_proper; intuition.
+ - destruct (f k e); auto.
+ - now rewrite H0 in H2.
+ Qed.
+
+ Lemma exists_iff f m :
+ Proper (E.eq==>eq==>eq) f ->
+ (exists_ f m = true <->
+ (exists k e, MapsTo k e m /\ f k e = true)).
+ Proof.
+ intros Hf.
+ rewrite exists_filter. rewrite negb_true_iff.
+ rewrite <- not_true_iff_false, <- is_empty_iff.
+ split.
+ - intros H. apply not_empty_mapsto in H. now setoid_rewrite filter_iff in H.
+ - unfold Empty. setoid_rewrite filter_iff; trivial. firstorder.
+ Qed.
+
+ 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 E.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 with map. }
+ 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 E.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 with map.
+
+ - (* 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 E.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 with map.
+ 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 ->
+ Diamond 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 with map.
+ 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 with map.
+ 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); compute; auto with map. congruence.
+ 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. bindings) *)
+
+ 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.
+
+ Instance cardinal_m {elt} : Proper (Equal ==> Logic.eq) (@cardinal elt).
+ Proof. intros m m'. apply Equal_cardinal. Qed.
+
+ Instance Disjoint_m {elt} : Proper (Equal ==> Equal ==> iff) (@Disjoint elt).
+ Proof.
+ intros m1 m1' Hm1 m2 m2' Hm2. unfold Disjoint. split; intros.
+ rewrite <- Hm1, <- Hm2; auto.
+ rewrite Hm1, Hm2; auto.
+ Qed.
+
+ Instance Partition_m {elt} :
+ Proper (Equal ==> Equal ==> Equal ==> iff) (@Partition elt).
+ 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.
+
+(*
+ Instance filter_m0 {elt} (f:key->elt->bool) :
+ Proper (E.eq==>Logic.eq==>Logic.eq) f ->
+ Proper (Equal==>Equal) (filter f).
+ Proof.
+ intros Hf m m' Hm. apply Equal_mapsto_iff. intros.
+ now rewrite !filter_iff, Hm.
+ Qed.
+*)
+
+ Instance filter_m {elt} :
+ Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Equal) (@filter elt).
+ Proof.
+ intros f f' Hf m m' Hm. unfold filter.
+ rewrite 2 fold_spec_right.
+ set (l := rev (bindings m)).
+ set (l' := rev (bindings m')).
+ set (op := fun (f:key->elt->bool) =>
+ uncurry (fun k e acc => if f k e then add k e acc else acc)).
+ change (Equal (fold_right (op f) empty l) (fold_right (op f') empty l')).
+ assert (Hl : NoDupA eq_key l).
+ { apply NoDupA_rev. apply eqk_equiv. apply bindings_spec2w. }
+ assert (Hl' : NoDupA eq_key l').
+ { apply NoDupA_rev. apply eqk_equiv. apply bindings_spec2w. }
+ assert (H : PermutationA eq_key_elt l l').
+ { apply NoDupA_equivlistA_PermutationA.
+ - apply eqke_equiv.
+ - now apply NoDupA_eqk_eqke.
+ - now apply NoDupA_eqk_eqke.
+ - intros (k,e); unfold l, l'. rewrite 2 InA_rev, 2 bindings_spec1.
+ rewrite Equal_mapsto_iff in Hm. apply Hm. }
+ destruct (PermutationA_decompose (eqke_equiv _) H) as (l0,(P,E)).
+ transitivity (fold_right (op f) empty l0).
+ - apply fold_right_equivlistA_restr2
+ with (eqA:=Logic.eq)(R:=complement eq_key); auto with *.
+ + intros p p' <- acc acc' Hacc.
+ destruct p as (k,e); unfold op, uncurry; simpl.
+ destruct (f k e); now rewrite Hacc.
+ + intros (k,e) (k',e') z z'.
+ unfold op, complement, uncurry, eq_key; simpl.
+ intros Hk Hz.
+ destruct (f k e), (f k' e'); rewrite <- Hz; try reflexivity.
+ now apply add_add_2.
+ + apply NoDupA_incl with eq_key; trivial. intros; subst; now red.
+ + apply PermutationA_preserves_NoDupA with l; auto with *.
+ apply Permutation_PermutationA; auto with *.
+ apply NoDupA_incl with eq_key; trivial. intros; subst; now red.
+ + apply NoDupA_altdef. apply NoDupA_rev. apply eqk_equiv.
+ apply bindings_spec2w.
+ + apply PermutationA_equivlistA; auto with *.
+ apply Permutation_PermutationA; auto with *.
+ - clearbody l'. clear l Hl Hl' H P m m' Hm.
+ induction E.
+ + reflexivity.
+ + simpl. destruct x as (k,e), x' as (k',e').
+ unfold op, uncurry at 1 3; simpl.
+ destruct H; simpl in *. rewrite <- (Hf _ _ H _ _ H0).
+ destruct (f k e); trivial. now f_equiv.
+ Qed.
+
+ Instance for_all_m {elt} :
+ Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Logic.eq) (@for_all elt).
+ Proof.
+ intros f f' Hf m m' Hm. rewrite 2 for_all_filter.
+ (* Strange: we cannot rewrite Hm here... *)
+ f_equiv. f_equiv; trivial.
+ intros k k' Hk e e' He. f_equal. now apply Hf.
+ Qed.
+
+ Instance exists_m {elt} :
+ Proper ((E.eq==>Logic.eq==>Logic.eq)==>Equal==>Logic.eq) (@exists_ elt).
+ Proof.
+ intros f f' Hf m m' Hm. rewrite 2 exists_filter.
+ f_equal. now apply is_empty_m, filter_m.
+ Qed.
+
+ Fact diamond_add {elt} : Diamond Equal (@add elt).
+ Proof.
+ intros k k' e e' a b b' Hk <- <-. now apply add_add_2.
+ Qed.
+
+ Instance update_m {elt} : Proper (Equal ==> Equal ==> Equal) (@update elt).
+ Proof.
+ intros m1 m1' Hm1 m2 m2' Hm2.
+ unfold update.
+ apply fold_Proper; auto using diamond_add with *.
+ Qed.
+
+ Instance restrict_m {elt} : Proper (Equal==>Equal==>Equal) (@restrict elt).
+ Proof.
+ intros m1 m1' Hm1 m2 m2' Hm2 y.
+ unfold restrict.
+ apply eq_option_alt. intros e.
+ rewrite !find_spec, !filter_iff, Hm1, Hm2. reflexivity.
+ clear. intros x x' Hx e e' He. now rewrite Hx.
+ clear. intros x x' Hx e e' He. now rewrite Hx.
+ Qed.
+
+ Instance diff_m {elt} : Proper (Equal==>Equal==>Equal) (@diff elt).
+ Proof.
+ intros m1 m1' Hm1 m2 m2' Hm2 y.
+ unfold diff.
+ apply eq_option_alt. intros e.
+ rewrite !find_spec, !filter_iff, Hm1, Hm2. reflexivity.
+ clear. intros x x' Hx e e' He. now rewrite Hx.
+ clear. intros x x' Hx e e' He. now rewrite Hx.
+ 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 M.
+
+ Section Elt.
+ Variable elt:Type.
+
+ 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 Bindings.
+
+ 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 klean := unfold O.eqke, O.ltk, RelCompFun in *; simpl in *.
+ Ltac keauto := klean; 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 bindings_lt p m := List.filter (gtb p) (bindings m).
+ Definition bindings_ge p m := List.filter (leb p) (bindings m).
+
+ Lemma gtb_1 : forall p p', gtb p p' = true <-> ltk p' p.
+ Proof.
+ intros (x,e) (y,e'); unfold gtb; klean.
+ case E.compare_spec; 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; klean.
+ case E.compare_spec; intuition; try discriminate; ME.order.
+ Qed.
+
+ Instance 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'')); klean; auto.
+ - intros. symmetry; rewrite H2. rewrite <-H, <-H1; auto.
+ - intros. rewrite H1. rewrite H, <- H2; auto.
+ Qed.
+
+ Instance leb_compat : forall p, Proper (eqke==>eq) (leb p).
+ Proof.
+ intros x a b H. unfold leb; f_equal; apply gtb_compat; auto.
+ Qed.
+
+ Hint Resolve gtb_compat leb_compat bindings_spec2 : map.
+
+ Lemma bindings_split : forall p m,
+ bindings m = bindings_lt p m ++ bindings_ge p m.
+ Proof.
+ unfold bindings_lt, bindings_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; klean.
+ apply not_true_iff_false in H0. rewrite gtb_1 in H0. klean. ME.order.
+ Qed.
+
+ Lemma bindings_Add : forall m m' x e, ~In x m -> Add x e m m' ->
+ eqlistA eqke (bindings m')
+ (bindings_lt (x,e) m ++ (x,e):: bindings_ge (x,e) m).
+ Proof.
+ intros; unfold bindings_lt, bindings_ge.
+ apply sort_equivlistA_eqlistA; auto with *.
+ - apply (@SortA_app _ eqke); auto with *.
+ + apply (@filter_sort _ eqke); auto with *; keauto.
+ + constructor; auto with map.
+ * apply (@filter_sort _ eqke); auto with *; keauto.
+ * rewrite (@InfA_alt _ eqke); auto with *; try (keauto; fail).
+ { intros.
+ rewrite filter_InA in H1; auto with *; destruct H1.
+ rewrite leb_1 in H2.
+ destruct y; klean.
+ rewrite <- bindings_mapsto_iff in H1.
+ assert (~E.eq x t0).
+ { contradict H.
+ exists e0; apply MapsTo_1 with t0; auto.
+ ME.order. }
+ ME.order. }
+ { apply (@filter_sort _ eqke); auto with *; keauto. }
+ + intros.
+ rewrite filter_InA in H1; auto with *; destruct H1.
+ rewrite gtb_1 in H3.
+ destruct y; destruct x0; klean.
+ inversion_clear H2.
+ * red in H4; klean; destruct H4; simpl in *. ME.order.
+ * rewrite filter_InA in H4; auto with *; destruct H4.
+ rewrite leb_1 in H4. klean; ME.order.
+ - intros (k,e').
+ rewrite InA_app_iff, InA_cons, 2 filter_InA,
+ <-2 bindings_mapsto_iff, leb_1, gtb_1,
+ find_mapsto_iff, (H0 k), <- find_mapsto_iff,
+ add_mapsto_iff by (auto with * ).
+ change (eqke (k,e') (x,e)) with (E.eq k x /\ e' = e).
+ klean.
+ split.
+ + intros [(->,->)|(Hk,Hm)].
+ * right; now left.
+ * destruct (lt_dec k x); intuition.
+ + intros [(Hm,LT)|[(->,->)|(Hm,EQ)]].
+ * right; split; trivial; ME.order.
+ * now left.
+ * destruct (eq_dec x k) as [Hk|Hk].
+ elim H. exists e'. now rewrite Hk.
+ right; auto.
+ Qed.
+
+ Lemma bindings_Add_Above : forall m m' x e,
+ Above x m -> Add x e m m' ->
+ eqlistA eqke (bindings m') (bindings 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 <- bindings_mapsto_iff in H1.
+ destruct H3; klean.
+ rewrite H2.
+ apply H; firstorder.
+ inversion H3.
+ red; intros a; destruct a.
+ rewrite InA_app_iff, InA_cons, InA_nil, <- 2 bindings_mapsto_iff,
+ find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
+ add_mapsto_iff by (auto with *).
+ change (eqke (t0,e0) (x,e)) with (E.eq t0 x /\ e0 = e).
+ intuition.
+ destruct (E.eq_dec x t0) as [Heq|Hneq]; auto.
+ exfalso.
+ assert (In t0 m) by (exists e0; auto).
+ generalize (H t0 H1).
+ ME.order.
+ Qed.
+
+ Lemma bindings_Add_Below : forall m m' x e,
+ Below x m -> Add x e m m' ->
+ eqlistA eqke (bindings m') ((x,e)::bindings m).
+ Proof.
+ intros.
+ apply sort_equivlistA_eqlistA; auto with *.
+ change (sort ltk (((x,e)::nil) ++ bindings m)).
+ apply (@SortA_app _ eqke); auto with *.
+ intros.
+ inversion_clear H1.
+ destruct y; destruct x0.
+ rewrite <- bindings_mapsto_iff in H2.
+ destruct H3; klean.
+ rewrite H1.
+ apply H; firstorder.
+ inversion H3.
+ red; intros a; destruct a.
+ rewrite InA_cons, <- 2 bindings_mapsto_iff,
+ find_mapsto_iff, (H0 t0), <- find_mapsto_iff,
+ add_mapsto_iff by (auto with * ).
+ change (eqke (t0,e0) (x,e)) with (E.eq t0 x /\ e0 = e).
+ intuition.
+ destruct (E.eq_dec x t0) as [Heq|Hneq]; auto.
+ exfalso.
+ assert (In t0 m) by (exists e0; auto).
+ generalize (H t0 H1).
+ ME.order.
+ Qed.
+
+ Lemma bindings_Equal_eqlistA : forall (m m': t elt),
+ Equal m m' -> eqlistA eqke (bindings m) (bindings m').
+ Proof.
+ intros.
+ apply sort_equivlistA_eqlistA; auto with *.
+ red; intros.
+ destruct x; do 2 rewrite <- bindings_mapsto_iff.
+ do 2 rewrite find_mapsto_iff; rewrite H; split; auto.
+ Qed.
+
+ End Bindings.
+
+ 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 (bindings 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 bindings_in_iff in H1.
+ destruct H1.
+ unfold max_elt in *.
+ generalize (bindings_spec2 m).
+ revert x e H y x0 H0 H1.
+ induction (bindings m).
+ simpl; intros; try discriminate.
+ intros.
+ destruct a; destruct l; simpl in *.
+ injection H; clear H; intros; subst.
+ inversion_clear H1.
+ red in H; simpl in *; intuition.
+ now elim H0.
+ 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].
+ rewrite <- Heq; auto.
+ inversion_clear H2.
+ inversion_clear H5.
+ red in H2; simpl in H2; ME.order.
+ transitivity p1; auto.
+ inversion_clear H2.
+ inversion_clear H5.
+ red in H2; simpl in H2; ME.order.
+ eapply IHl; eauto with *.
+ econstructor; eauto.
+ red; eauto with *.
+ 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 bindings_mapsto_iff.
+ induction (bindings m).
+ simpl; try discriminate.
+ destruct a; destruct l; simpl in *.
+ injection H; intros; subst; constructor; red; auto with *.
+ constructor 2; auto.
+ Qed.
+
+ Lemma max_elt_Empty :
+ forall m, max_elt m = None -> Empty m.
+ Proof.
+ intros.
+ unfold max_elt in *.
+ rewrite bindings_Empty.
+ induction (bindings m); auto.
+ destruct a; destruct l; simpl in *; try discriminate.
+ assert (H':=IHl H); discriminate.
+ Qed.
+
+ Definition min_elt m : option (key*elt) := match bindings 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 bindings_in_iff in H1.
+ destruct H1.
+ generalize (bindings_spec2 m).
+ destruct (bindings m).
+ try discriminate.
+ destruct p; injection H; intros; subst.
+ inversion_clear H1.
+ red in H2; destruct H2; simpl in *; ME.order.
+ inversion_clear H4.
+ rewrite (@InfA_alt _ eqke) in H3; eauto 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 bindings_mapsto_iff.
+ destruct (bindings m).
+ simpl; try discriminate.
+ destruct p; simpl in *.
+ injection H; intros; subst; constructor; red; auto with *.
+ Qed.
+
+ Lemma min_elt_Empty :
+ forall m, min_elt m = None -> Empty m.
+ Proof.
+ intros.
+ unfold min_elt in *.
+ rewrite bindings_Empty.
+ destruct (bindings 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).
+ { apply max_elt_MapsTo, find_spec, add_id in H.
+ unfold Add. symmetry. now rewrite add_remove_1. }
+ 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_S; 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).
+ { apply min_elt_MapsTo, find_spec, add_id in H.
+ unfold Add. symmetry. now rewrite add_remove_1. }
+ apply X0 with (remove k m) k e; auto.
+ apply IHn.
+ assert (S n = S (cardinal (remove k m))).
+ { rewrite Heqn.
+ eapply cardinal_S; eauto with map. }
+ inversion H1; auto.
+ eapply min_elt_Below; eauto.
+
+ apply X; apply min_elt_Empty; auto.
+ Qed.
+
+ End Induction_Principles.
+
+ Section Fold_properties.
+
+ (** The following lemma has already been proved on Weak Maps,
+ but with one additionnal hypothesis (some [transpose] fact). *)
+
+ Lemma fold_Equal : forall 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 bindings_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 (bindings 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 bindings_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)++bindings 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 bindings_Add_Below; auto.
+ rewrite distr_rev; simpl.
+ rewrite fold_right_app.
+ reflexivity.
+ Qed.
+
+ End Fold_properties.
+
+ End Elt.
+
+End OrdProperties.
diff --git a/theories/MMaps/MMapInterface.v b/theories/MMaps/MMapInterface.v
new file mode 100644
index 00000000..05c5e5d8
--- /dev/null
+++ b/theories/MMaps/MMapInterface.v
@@ -0,0 +1,292 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(** * Finite map library *)
+
+(** This file proposes interfaces for finite maps *)
+
+Require Export Bool Equalities Orders SetoidList.
+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
+ [bindings] 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
+
+*)
+
+
+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.
+
+ Definition eq_key {elt} (p p':key*elt) := E.eq (fst p) (fst p').
+
+ Definition eq_key_elt {elt} (p p':key*elt) :=
+ E.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+ Parameter t : Type -> Type.
+ (** the abstract type of maps *)
+
+ Section Ops.
+
+ Parameter empty : forall {elt}, t elt.
+ (** The empty map. *)
+
+ Variable elt:Type.
+
+ 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. *)
+
+ Parameter bindings : t elt -> list (key*elt).
+ (** [bindings 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. *)
+
+ 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 merge : (key -> option elt -> option elt' -> option elt'') ->
+ t elt -> t elt' -> t elt''.
+ (** [merge 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 k e e'] where [e] and [e'] are the (optional)
+ bindings of [k] in [m] and [m']. *)
+
+ End Ops.
+ Section Specs.
+
+ Variable elt:Type.
+
+ Parameter MapsTo : key -> elt -> t elt -> Prop.
+
+ Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m.
+
+ Global Declare Instance MapsTo_compat :
+ Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo.
+
+ Variable m m' : t elt.
+ Variable x y : key.
+ Variable e : elt.
+
+ Parameter find_spec : find x m = Some e <-> MapsTo x e m.
+ Parameter mem_spec : mem x m = true <-> In x m.
+ Parameter empty_spec : find x (@empty elt) = None.
+ Parameter is_empty_spec : is_empty m = true <-> forall x, find x m = None.
+ Parameter add_spec1 : find x (add x e m) = Some e.
+ Parameter add_spec2 : ~E.eq x y -> find y (add x e m) = find y m.
+ Parameter remove_spec1 : find x (remove x m) = None.
+ Parameter remove_spec2 : ~E.eq x y -> find y (remove x m) = find y m.
+
+ (** Specification of [bindings] *)
+ Parameter bindings_spec1 :
+ InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m.
+ (** When compared with ordered maps, here comes the only
+ property that is really weaker: *)
+ Parameter bindings_spec2w : NoDupA eq_key (bindings m).
+
+ (** Specification of [cardinal] *)
+ Parameter cardinal_spec : cardinal m = length (bindings m).
+
+ (** Specification of [fold] *)
+ Parameter fold_spec :
+ forall {A} (i : A) (f : key -> elt -> A -> A),
+ fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings 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':t elt) := 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] *)
+ Parameter equal_spec : forall cmp : elt -> elt -> bool,
+ equal cmp m m' = true <-> Equivb cmp m m'.
+
+ End Specs.
+ Section SpecMaps.
+
+ Variables elt elt' elt'' : Type.
+
+ Parameter map_spec : forall (f:elt->elt') m x,
+ find x (map f m) = option_map f (find x m).
+
+ Parameter mapi_spec : forall (f:key->elt->elt') m x,
+ exists y:key, E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+
+ Parameter merge_spec1 :
+ forall (f:key->option elt->option elt'->option elt'') m m' x,
+ In x m \/ In x m' ->
+ exists y:key, E.eq y x /\
+ find x (merge f m m') = f y (find x m) (find x m').
+
+ Parameter merge_spec2 :
+ forall (f:key -> option elt->option elt'->option elt'') m m' x,
+ In x (merge f m m') -> In x m \/ In x m'.
+
+ End SpecMaps.
+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.
+
+ Definition lt_key {elt} (p p':key*elt) := E.lt (fst p) (fst p').
+
+ (** Additional specification of [bindings] *)
+
+ Parameter bindings_spec2 : forall {elt}(m : t elt), sort lt_key (bindings m).
+
+ (** Remark: since [fold] is specified via [bindings], this stronger
+ specification of [bindings] has an indirect impact on [fold],
+ which can now be proved to receive bindings in increasing order. *)
+
+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.
+
+ Include HasEq <+ HasLt <+ IsEq <+ IsStrOrder.
+
+ Definition cmp e e' :=
+ match Data.compare e e' with Eq => true | _ => false end.
+
+ Parameter eq_spec : forall m m', eq m m' <-> Equivb cmp m m'.
+
+ Parameter compare : t -> t -> comparison.
+
+ Parameter compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2).
+
+End Sord.
+
+
+(* TODO: provides filter + partition *)
+
+(* TODO: provide split
+ Parameter split : key -> t elt -> t elt * option elt * t elt.
+
+ Parameter split_spec k m :
+ split k m = (filter (fun x -> E.compare x k) m, find k m, filter ...)
+
+ min_binding, max_binding, choose ?
+*)
diff --git a/theories/MMaps/MMapList.v b/theories/MMaps/MMapList.v
new file mode 100644
index 00000000..c521178c
--- /dev/null
+++ b/theories/MMaps/MMapList.v
@@ -0,0 +1,1144 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(** * Finite map library *)
+
+(** This file proposes an implementation of the non-dependant interface
+ [MMapInterface.S] using lists of pairs ordered (increasing) with respect to
+ left projection. *)
+
+Require Import MMapInterface OrdersFacts OrdersLists.
+
+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).
+
+Local Notation Sort := (sort ltk).
+Local Notation Inf := (lelistA (ltk)).
+
+Section Elt.
+Variable elt : Type.
+
+Ltac SortLt :=
+ match goal with
+ | H1 : Sort ?m, H2:Inf (?k',?e') ?m, H3:In ?k ?m |- _ =>
+ assert (X.lt k' k);
+ [let e := fresh "e" in destruct H3 as (e,H3);
+ change (ltk (k',e') (k,e));
+ apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ]
+ | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:MapsTo ?k ?e ?m |- _ =>
+ assert (X.lt k' k);
+ [change (ltk (k',e') (k,e));
+ apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ]
+ | H1:Sort ?m, H2:Inf (?k',?e') ?m, H3:InA eqke (?k,?e) ?m |- _ =>
+ assert (X.lt k' k);
+ [change (ltk (k',e') (k,e));
+ apply (Sort_Inf_In H1 H2 (InA_eqke_eqk H3)) | ]
+ end.
+
+(** * [find] *)
+
+Fixpoint find (k:key) (m: t elt) : option elt :=
+ match m with
+ | nil => None
+ | (k',x)::m' =>
+ match X.compare k k' with
+ | Lt => None
+ | Eq => Some x
+ | Gt => find k m'
+ end
+ end.
+
+Lemma find_spec m (Hm:Sort m) x e :
+ find x m = Some e <-> MapsTo x e m.
+Proof.
+ induction m as [|(k,e') m IH]; simpl.
+ - split. discriminate. inversion 1.
+ - inversion_clear Hm.
+ unfold MapsTo in *. rewrite InA_cons, eqke_def.
+ case X.compare_spec; intros.
+ + split. injection 1 as ->; auto.
+ intros [(_,<-)|IN]; trivial. SortLt. MX.order.
+ + split. discriminate.
+ intros [(E,<-)|IN]; trivial; try SortLt; MX.order.
+ + rewrite IH; trivial. split; auto.
+ intros [(E,<-)|IN]; trivial. MX.order.
+Qed.
+
+(** * [mem] *)
+
+Fixpoint mem (k : key) (m : t elt) : bool :=
+ match m with
+ | nil => false
+ | (k',_) :: l =>
+ match X.compare k k' with
+ | Lt => false
+ | Eq => true
+ | Gt => mem k l
+ end
+ end.
+
+Lemma mem_spec m (Hm:Sort m) x : mem x m = true <-> In x m.
+Proof.
+ induction m as [|(k,e') m IH]; simpl.
+ - split. discriminate. inversion 1. inversion_clear H0.
+ - inversion_clear Hm.
+ rewrite In_cons; simpl.
+ case X.compare_spec; intros.
+ + intuition.
+ + split. discriminate. intros [E|(e,IN)]. MX.order.
+ SortLt. MX.order.
+ + rewrite IH; trivial. split; auto. intros [E|IN]; trivial.
+ MX.order.
+Qed.
+
+(** * [empty] *)
+
+Definition empty : t elt := nil.
+
+Lemma empty_spec x : find x empty = None.
+Proof.
+ reflexivity.
+Qed.
+
+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_spec m :
+ is_empty m = true <-> forall x, find x m = None.
+Proof.
+ destruct m as [|(k,e) m]; simpl; split; trivial; try discriminate.
+ intros H. specialize (H k). now rewrite compare_refl in H.
+Qed.
+
+(** * [add] *)
+
+Fixpoint add (k : key) (x : elt) (s : t elt) : 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_spec1 m x e : find x (add x e m) = Some e.
+Proof.
+ induction m as [|(k,e') m IH]; simpl.
+ - now rewrite compare_refl.
+ - case X.compare_spec; simpl; rewrite ?compare_refl; trivial.
+ rewrite <- compare_gt_iff. now intros ->.
+Qed.
+
+Lemma add_spec2 m x y e : ~X.eq x y -> find y (add x e m) = find y m.
+Proof.
+ induction m as [|(k,e') m IH]; simpl.
+ - case X.compare_spec; trivial; MX.order.
+ - case X.compare_spec; simpl; intros; trivial.
+ + rewrite <-H. case X.compare_spec; trivial; MX.order.
+ + do 2 (case X.compare_spec; trivial; try MX.order).
+ + now rewrite IH.
+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; intuition.
+Qed.
+Hint Resolve add_Inf.
+
+Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x',e').
+ simpl; case (X.compare_spec x x'); intuition; inversion_clear Hm; auto.
+ constructor; auto.
+ apply Inf_eq with (x',e'); auto.
+Qed.
+
+(** * [remove] *)
+
+Fixpoint remove (k : key) (s : t elt) : 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_spec1 m (Hm:Sort m) x : find x (remove x m) = None.
+Proof.
+ induction m as [|(k,e') m IH]; simpl; trivial.
+ inversion_clear Hm.
+ case X.compare_spec; simpl.
+ - intros E. rewrite <- E in H0.
+ apply Sort_Inf_NotIn in H0; trivial. unfold In in H0.
+ setoid_rewrite <- find_spec in H0; trivial.
+ destruct (find x m); trivial.
+ elim H0; now exists e.
+ - rewrite <- compare_lt_iff. now intros ->.
+ - rewrite <- compare_gt_iff. intros ->; auto.
+Qed.
+
+Lemma remove_spec2 m (Hm:Sort m) x y :
+ ~X.eq x y -> find y (remove x m) = find y m.
+Proof.
+ induction m as [|(k,e') m IH]; simpl; trivial.
+ inversion_clear Hm.
+ case X.compare_spec; simpl; intros E E'; try rewrite IH; auto.
+ case X.compare_spec; simpl; trivial; try MX.order.
+ intros. rewrite <- E in H0,H1. clear E E'.
+ destruct (find y m) eqn:F; trivial.
+ apply find_spec in F; trivial.
+ SortLt. MX.order.
+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; intuition.
+ inversion_clear Hm.
+ apply Inf_lt with (x'',e''); auto.
+Qed.
+Hint Resolve remove_Inf.
+
+Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m).
+Proof.
+ induction m.
+ simpl; intuition.
+ intros.
+ destruct a as (x',e').
+ simpl; case X.compare_spec; intuition; inversion_clear Hm; auto.
+Qed.
+
+(** * [bindings] *)
+
+Definition bindings (m: t elt) := m.
+
+Lemma bindings_spec1 m x e :
+ InA eqke (x,e) (bindings m) <-> MapsTo x e m.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma bindings_spec2 m (Hm:Sort m) : sort ltk (bindings m).
+Proof.
+ auto.
+Qed.
+
+Lemma bindings_spec2w m (Hm:Sort m) : NoDupA eqk (bindings m).
+Proof.
+ now apply Sort_NoDupA.
+Qed.
+
+(** * [fold] *)
+
+Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) : A :=
+ match m with
+ | nil => acc
+ | (k,e)::m' => fold f m' (f k e acc)
+ end.
+
+Lemma fold_spec m : 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) (bindings m) i.
+Proof.
+ induction m as [|(k,e) m IH]; simpl; auto.
+Qed.
+
+(** * [equal] *)
+
+Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) : 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:elt->elt->bool) m m' :=
+ (forall k, In k m <-> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
+
+Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp,
+ Equivb cmp m m' -> equal cmp m m' = true.
+Proof.
+ induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl.
+ - trivial.
+ - intros _ cmp (H,_).
+ exfalso. apply (@In_nil elt k'). rewrite H, In_cons. now left.
+ - intros _ cmp (H,_).
+ exfalso. apply (@In_nil elt k). rewrite <- H, In_cons. now left.
+ - intros Hm' cmp E.
+ inversion_clear Hm; inversion_clear Hm'.
+ case X.compare_spec; intros E'.
+ + apply andb_true_intro; split.
+ * eapply E; eauto. apply InA_cons; now left.
+ * apply IH; clear IH; trivial.
+ destruct E as (E1,E2). split.
+ { intros x. clear E2.
+ split; intros; SortLt.
+ specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1.
+ destruct E1 as ([E1|E1],_); eauto. MX.order.
+ specialize (E1 x); rewrite 2 In_cons in E1; simpl in E1.
+ destruct E1 as (_,[E1|E1]); eauto. MX.order. }
+ { intros x xe xe' Hx HX'. eapply E2; eauto. }
+ + assert (IN : In k ((k',e')::m')).
+ { apply E. apply In_cons; now left. }
+ apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order.
+ SortLt. MX.order.
+ + assert (IN : In k' ((k,e)::m)).
+ { apply E. apply In_cons; now left. }
+ apply In_cons in IN. simpl in IN. destruct IN as [?|IN]. MX.order.
+ SortLt. MX.order.
+Qed.
+
+Lemma equal_2 m (Hm:Sort m) m' (Hm':Sort m') cmp :
+ equal cmp m m' = true -> Equivb cmp m m'.
+Proof.
+ revert m' Hm'.
+ induction m as [|(k,e) m IH]; destruct m' as [|(k',e') m']; simpl;
+ try discriminate.
+ - split. reflexivity. inversion 1.
+ - intros Hm'. case X.compare_spec; try discriminate.
+ rewrite andb_true_iff. intros E (C,EQ).
+ inversion_clear Hm; inversion_clear Hm'.
+ apply IH in EQ; trivial.
+ destruct EQ as (E1,E2).
+ split.
+ + intros x. rewrite 2 In_cons; simpl. rewrite <- E1.
+ intuition; now left; MX.order.
+ + intros x ex ex'. unfold MapsTo in *. rewrite 2 InA_cons, 2 eqke_def.
+ intuition; subst.
+ * trivial.
+ * SortLt. MX.order.
+ * SortLt. MX.order.
+ * eapply E2; eauto.
+Qed.
+
+Lemma equal_spec m (Hm:Sort m) m' (Hm':Sort m') cmp :
+ equal cmp m m' = true <-> Equivb cmp m m'.
+Proof.
+ split. now apply equal_2. now apply equal_1.
+Qed.
+
+(** This lemma isn't part of the spec of [Equivb], but is used in [MMapAVL] *)
+
+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.
+ case X.compare_spec; intros; try MX.order.
+ rewrite H2; simpl.
+ apply equal_1; auto.
+ apply equal_2; auto.
+ generalize (equal_1 H H0 H3).
+ simpl.
+ case X.compare_spec; try discriminate.
+ rewrite andb_true_iff. intuition.
+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.
+Arguments find {elt} k m.
+Section Elt2.
+Variable elt elt' : Type.
+
+(** Specification of [map] *)
+
+Lemma map_spec (f:elt->elt') m x :
+ find x (map f m) = option_map f (find x m).
+Proof.
+ induction m as [|(k,e) m IH]; simpl; trivial.
+ now case X.compare_spec.
+Qed.
+
+Lemma map_Inf (f:elt->elt') m x e e' :
+ Inf (x,e) m -> Inf (x,e') (map f m).
+Proof.
+ induction m as [|(x0,e0) m IH]; simpl; auto.
+ inversion_clear 1; auto.
+Qed.
+Hint Resolve map_Inf.
+
+Lemma map_sorted (f:elt->elt')(m: t elt)(Hm : Sort m) :
+ Sort (map f m).
+Proof.
+ induction m as [|(x,e) m IH]; simpl; auto.
+ inversion_clear Hm. constructor; eauto.
+Qed.
+
+(** Specification of [mapi] *)
+
+Lemma mapi_spec (f:key->elt->elt') m x :
+ exists y, X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+Proof.
+ induction m as [|(k,e) m IH]; simpl.
+ - now exists x.
+ - elim X.compare_spec; intros; simpl.
+ + now exists k.
+ + now exists x.
+ + apply IH.
+Qed.
+
+Lemma mapi_Inf (f:key->elt->elt') m x e :
+ Inf (x,e) m -> Inf (x,f x e) (mapi f m).
+Proof.
+ induction m as [|(x0,e0) m IH]; simpl; auto.
+ inversion_clear 1; auto.
+Qed.
+Hint Resolve mapi_Inf.
+
+Lemma mapi_sorted (f:key->elt->elt') m (Hm : Sort m) :
+ Sort (mapi f m).
+Proof.
+ induction m as [|(x,e) m IH]; simpl; auto.
+ inversion_clear Hm; auto.
+Qed.
+
+End Elt2.
+Section Elt3.
+
+(** * [merge] *)
+
+Variable elt elt' elt'' : Type.
+Variable f : key -> option elt -> option elt' -> option elt''.
+
+Definition option_cons {A}(k:key)(o:option A)(l:list (key*A)) :=
+ match o with
+ | Some e => (k,e)::l
+ | None => l
+ end.
+
+Fixpoint merge_l (m : t elt) : t elt'' :=
+ match m with
+ | nil => nil
+ | (k,e)::l => option_cons k (f k (Some e) None) (merge_l l)
+ end.
+
+Fixpoint merge_r (m' : t elt') : t elt'' :=
+ match m' with
+ | nil => nil
+ | (k,e')::l' => option_cons k (f k None (Some e')) (merge_r l')
+ end.
+
+Fixpoint merge (m : t elt) : t elt' -> t elt'' :=
+ match m with
+ | nil => merge_r
+ | (k,e) :: l =>
+ fix merge_aux (m' : t elt') : t elt'' :=
+ match m' with
+ | nil => merge_l m
+ | (k',e') :: l' =>
+ match X.compare k k' with
+ | Lt => option_cons k (f k (Some e) None) (merge l m')
+ | Eq => option_cons k (f k (Some e) (Some e')) (merge l l')
+ | Gt => option_cons k' (f k' None (Some e')) (merge_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}(f: A->B->C->C)(l:list (A*B))(i:C) :=
+ List.fold_right (fun p => f (fst p) (snd p)) i l.
+
+Definition merge' m m' :=
+ let m0 : t oee' := combine m m' in
+ let m1 : t (option elt'') := mapi (fun k p => f k (fst p) (snd p)) m0 in
+ fold_right_pair (option_cons (A:=elt'')) m1 nil.
+
+Lemma merge_equiv : forall m m', merge' m m' = merge m m'.
+Proof.
+ unfold merge'.
+ induction m as [|(k,e) m IHm]; intros.
+ - (* merge_r *)
+ simpl.
+ induction m' as [|(k',e') m' IHm']; simpl; rewrite ?IHm'; auto.
+ - induction m' as [|(k',e') m' IHm']; simpl.
+ + f_equal.
+ (* merge_l *)
+ clear k e IHm.
+ induction m as [|(k,e) m IHm]; simpl; rewrite ?IHm; auto.
+ + elim X.compare_spec; intros; simpl; f_equal.
+ * apply IHm.
+ * apply IHm.
+ * apply IHm'.
+Qed.
+
+Lemma combine_Inf :
+ forall m m' (x:key)(e:elt)(e':elt')(e'':oee'),
+ Inf (x,e) m ->
+ Inf (x,e') m' ->
+ Inf (x,e'') (combine m m').
+Proof.
+ induction m.
+ - intros. simpl. eapply map_Inf; eauto.
+ - induction m'; intros.
+ + destruct a.
+ replace (combine ((t0, e0) :: m) nil) with
+ (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto.
+ eapply map_Inf; eauto.
+ + simpl.
+ destruct a as (k,e0); destruct a0 as (k',e0').
+ elim X.compare_spec.
+ * inversion_clear H; auto.
+ * inversion_clear H; auto.
+ * inversion_clear H0; auto.
+Qed.
+Hint Resolve combine_Inf.
+
+Lemma combine_sorted m (Hm : Sort m) m' (Hm' : Sort m') :
+ Sort (combine m m').
+Proof.
+ revert m' Hm'.
+ 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.
+ + simpl.
+ destruct a as (k,e); destruct a0 as (k',e').
+ inversion_clear Hm; inversion_clear Hm'.
+ case X.compare_spec; [intros Heq| intros Hlt| intros Hlt];
+ constructor; auto.
+ * assert (Inf (k, e') m') by (apply Inf_eq with (k',e'); auto).
+ exact (combine_Inf _ H0 H3).
+ * assert (Inf (k, e') ((k',e')::m')) by auto.
+ exact (combine_Inf _ H0 H3).
+ * assert (Inf (k', e) ((k,e)::m)) by auto.
+ exact (combine_Inf _ H3 H2).
+Qed.
+
+Lemma merge_sorted m (Hm : Sort m) m' (Hm' : Sort m') :
+ Sort (merge m m').
+Proof.
+ intros.
+ rewrite <- merge_equiv.
+ unfold merge'.
+ assert (Hmm':=combine_sorted Hm Hm').
+ set (l0:=combine m m') in *; clearbody l0.
+ set (f':= fun k p => f k (fst p) (snd p)).
+ assert (H1:=mapi_sorted f' Hmm').
+ set (l1:=mapi f' l0) in *; clearbody l1.
+ clear f' f Hmm' l0 Hm Hm' m m'.
+ (* Sort fold_right_pair *)
+ induction l1.
+ - simpl; auto.
+ - inversion_clear H1.
+ destruct a; destruct o; auto.
+ simpl.
+ constructor; auto.
+ clear IHl1.
+ (* Inf fold_right_pair *)
+ induction l1.
+ + simpl; auto.
+ + destruct a; destruct o; simpl; auto.
+ * inversion_clear H0; auto.
+ * inversion_clear H0. inversion_clear H.
+ compute in H1.
+ apply IHl1; auto.
+ apply Inf_lt with (t1, None); 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_spec m (Hm : Sort m) m' (Hm' : Sort m') (x:key) :
+ find x (combine m m') = at_least_one (find x m) (find x m').
+Proof.
+ revert m' Hm'.
+ 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_spec 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_spec k k'); simpl;
+ destruct (X.compare_spec x k);
+ MX.order || destruct (X.compare_spec x k');
+ simpl; try MX.order; auto.
+ - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order.
+ - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order.
+ - rewrite IHm; auto; simpl. elim X.compare_spec; auto; MX.order.
+ - change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')).
+ rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order.
+ - change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')).
+ rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order.
+ - change (find x (combine ((k, e) :: m) m') =
+ at_least_one (find x m) (find x m')).
+ rewrite IHm'; auto; simpl. elim X.compare_spec; auto; MX.order.
+Qed.
+
+Definition at_least_one_then_f k (o:option elt)(o':option elt') :=
+ match o, o' with
+ | None, None => None
+ | _, _ => f k o o'
+ end.
+
+Lemma merge_spec0 m (Hm : Sort m) m' (Hm' : Sort m') (x:key) :
+ exists y, X.eq y x /\
+ find x (merge m m') = at_least_one_then_f y (find x m) (find x m').
+Proof.
+ intros.
+ rewrite <- merge_equiv.
+ unfold merge'.
+ assert (H:=combine_spec Hm Hm' x).
+ assert (H2:=combine_sorted Hm Hm').
+ set (f':= fun k p => f k (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'. revert H.
+ match goal with |- ?G =>
+ assert (G/\(find x m0 = None ->
+ find x (fold_right_pair option_cons (mapi f' m0) nil) = None));
+ [|intuition] end.
+ induction m0; simpl in *; intuition.
+ - exists x; split; [easy|].
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ - destruct a as (k,(oo,oo')); simpl in *.
+ inversion_clear H2.
+ destruct (X.compare_spec x k) as [Heq|Hlt|Hlt]; simpl in *.
+ + (* x = k *)
+ exists k; split; [easy|].
+ assert (at_least_one_then_f k o o' = f k oo oo').
+ { destruct o; destruct o'; simpl in *; inversion_clear H; auto. }
+ rewrite H2.
+ unfold f'; simpl.
+ destruct (f k oo oo'); simpl.
+ * elim X.compare_spec; trivial; try MX.order.
+ * 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'))).
+ now compute.
+ symmetry in H5.
+ destruct (Sort_Inf_NotIn H0 (Inf_eq H5 H1)).
+ exists p; apply find_spec; auto.
+ + (* x < k *)
+ destruct (f' k (oo,oo')); simpl.
+ * elim X.compare_spec; trivial; try MX.order.
+ destruct o; destruct o'; simpl in *; try discriminate; auto.
+ now exists x.
+ * apply IHm0; trivial.
+ 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 H3 H1)).
+ exists p; apply find_spec; auto.
+ + (* k < x *)
+ unfold f'; simpl.
+ destruct (f k oo oo'); simpl.
+ * elim X.compare_spec; trivial; try MX.order.
+ intros. apply IHm0; auto.
+ * apply IHm0; auto.
+
+ - (* None -> None *)
+ destruct a as (k,(oo,oo')).
+ simpl.
+ inversion_clear H2.
+ destruct (X.compare_spec x k) as [Hlt|Heq|Hlt]; try discriminate.
+ + (* x < k *)
+ unfold f'; simpl.
+ destruct (f k oo oo'); simpl.
+ elim X.compare_spec; trivial; try MX.order. intros.
+ apply IHm0; auto.
+ case_eq (find x m0); intros; auto.
+ assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))).
+ now compute.
+ destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)).
+ exists p; apply find_spec; auto.
+ + (* k < x *)
+ unfold f'; simpl.
+ destruct (f k oo oo'); simpl.
+ elim X.compare_spec; trivial; try MX.order. intros.
+ apply IHm0; auto.
+ apply IHm0; auto.
+Qed.
+
+(** Specification of [merge] *)
+
+Lemma merge_spec1 m (Hm : Sort m) m' (Hm' : Sort m')(x:key) :
+ In x m \/ In x m' ->
+ exists y, X.eq y x /\
+ find x (merge m m') = f y (find x m) (find x m').
+Proof.
+ intros.
+ destruct (merge_spec0 Hm Hm' x) as (y,(Hy,H')).
+ exists y; split; [easy|]. rewrite H'.
+ destruct H as [(e,H)|(e,H)];
+ apply find_spec in H; trivial; rewrite H; simpl; auto.
+ now destruct (find x m).
+Qed.
+
+Lemma merge_spec2 m (Hm : Sort m) m' (Hm' : Sort m')(x:key) :
+ In x (merge m m') -> In x m \/ In x m'.
+Proof.
+ intros.
+ destruct H as (e,H).
+ apply find_spec in H; auto using merge_sorted.
+ destruct (merge_spec0 Hm Hm' x) as (y,(Hy,H')).
+ rewrite H in H'.
+ destruct (find x m) eqn:F.
+ - apply find_spec in F; eauto.
+ - destruct (find x m') eqn:F'.
+ + apply find_spec in F'; eauto.
+ + simpl in H'. 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.
+Definition eq_key {elt} := @Raw.PX.eqk elt.
+Definition eq_key_elt {elt} := @Raw.PX.eqke elt.
+Definition lt_key {elt} := @Raw.PX.ltk elt.
+
+Record t_ (elt:Type) := Mk
+ {this :> Raw.t elt;
+ sorted : sort Raw.PX.ltk this}.
+Definition t := t_.
+
+Definition empty {elt} := Mk (Raw.empty_sorted elt).
+
+Section Elt.
+ Variable elt elt' elt'':Type.
+
+ Implicit Types m : t elt.
+ Implicit Types x y : key.
+ Implicit Types e : elt.
+
+ Definition is_empty m : bool := Raw.is_empty m.(this).
+ Definition add x e m : t elt := Mk (Raw.add_sorted m.(sorted) x e).
+ Definition find x m : option elt := Raw.find x m.(this).
+ Definition remove x m : t elt := Mk (Raw.remove_sorted m.(sorted) x).
+ Definition mem x m : bool := Raw.mem x m.(this).
+ Definition map f m : t elt' := Mk (Raw.map_sorted f m.(sorted)).
+ Definition mapi (f:key->elt->elt') m : t elt' :=
+ Mk (Raw.mapi_sorted f m.(sorted)).
+ Definition merge f m (m':t elt') : t elt'' :=
+ Mk (Raw.merge_sorted f m.(sorted) m'.(sorted)).
+ Definition bindings m : list (key*elt) := Raw.bindings m.(this).
+ Definition cardinal m := length m.(this).
+ Definition fold {A:Type}(f:key->elt->A->A) m (i:A) : A :=
+ Raw.fold f m.(this) i.
+ Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this).
+
+ Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this).
+ Definition In x m : Prop := Raw.PX.In x m.(this).
+
+ Definition Equal m m' := forall y, find y m = find y m'.
+ Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
+ (forall k, In k m <-> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
+ Definition Equivb cmp m m' : Prop := @Raw.Equivb elt cmp m.(this) m'.(this).
+
+ Instance MapsTo_compat :
+ Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo.
+ Proof.
+ intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx.
+ Qed.
+
+ Lemma find_spec m : forall x e, find x m = Some e <-> MapsTo x e m.
+ Proof. exact (Raw.find_spec m.(sorted)). Qed.
+
+ Lemma mem_spec m : forall x, mem x m = true <-> In x m.
+ Proof. exact (Raw.mem_spec m.(sorted)). Qed.
+
+ Lemma empty_spec : forall x, find x empty = None.
+ Proof. exact (Raw.empty_spec _). Qed.
+
+ Lemma is_empty_spec m : is_empty m = true <-> (forall x, find x m = None).
+ Proof. exact (Raw.is_empty_spec m.(this)). Qed.
+
+ Lemma add_spec1 m : forall x e, find x (add x e m) = Some e.
+ Proof. exact (Raw.add_spec1 m.(this)). Qed.
+ Lemma add_spec2 m : forall x y e, ~E.eq x y -> find y (add x e m) = find y m.
+ Proof. exact (Raw.add_spec2 m.(this)). Qed.
+
+ Lemma remove_spec1 m : forall x, find x (remove x m) = None.
+ Proof. exact (Raw.remove_spec1 m.(sorted)). Qed.
+ Lemma remove_spec2 m : forall x y, ~E.eq x y -> find y (remove x m) = find y m.
+ Proof. exact (Raw.remove_spec2 m.(sorted)). Qed.
+
+ Lemma bindings_spec1 m : forall x e,
+ InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m.
+ Proof. exact (Raw.bindings_spec1 m.(this)). Qed.
+ Lemma bindings_spec2w m : NoDupA eq_key (bindings m).
+ Proof. exact (Raw.bindings_spec2w m.(sorted)). Qed.
+ Lemma bindings_spec2 m : sort lt_key (bindings m).
+ Proof. exact (Raw.bindings_spec2 m.(sorted)). Qed.
+
+ Lemma cardinal_spec m : cardinal m = length (bindings m).
+ Proof. reflexivity. Qed.
+
+ Lemma fold_spec m : 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) (bindings m) i.
+ Proof. exact (Raw.fold_spec m.(this)). Qed.
+
+ Lemma equal_spec m m' : forall cmp, equal cmp m m' = true <-> Equivb cmp m m'.
+ Proof. exact (Raw.equal_spec m.(sorted) m'.(sorted)). Qed.
+
+End Elt.
+
+ Lemma map_spec {elt elt'} (f:elt->elt') m :
+ forall x, find x (map f m) = option_map f (find x m).
+ Proof. exact (Raw.map_spec f m.(this)). Qed.
+
+ Lemma mapi_spec {elt elt'} (f:key->elt->elt') m :
+ forall x, exists y,
+ E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+ Proof. exact (Raw.mapi_spec f m.(this)). Qed.
+
+ Lemma merge_spec1 {elt elt' elt''}
+ (f:key->option elt->option elt'->option elt'') m m' :
+ forall x,
+ In x m \/ In x m' ->
+ exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m').
+ Proof. exact (Raw.merge_spec1 f m.(sorted) m'.(sorted)). Qed.
+
+ Lemma merge_spec2 {elt elt' elt''}
+ (f:key->option elt->option elt'->option elt'') m m' :
+ forall x,
+ In x (merge f m m') -> In x m \/ In x m'.
+ Proof. exact (Raw.merge_spec2 m.(sorted) m'.(sorted)). 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 m.(this) m'.(this).
+
+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 m.(this) m'.(this).
+
+Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true.
+Proof.
+ intros (l,Hl); induction l.
+ intros (l',Hl'); unfold eq; simpl.
+ destruct l'; unfold equal; simpl; intuition.
+ intros (l',Hl'); unfold eq.
+ destruct l'.
+ destruct a; unfold equal; simpl; intuition.
+ destruct a as (x,e).
+ destruct p as (x',e').
+ unfold equal; simpl.
+ destruct (X.compare_spec x x') as [Hlt|Heq|Hlt]; simpl; intuition.
+ unfold cmp at 1.
+ elim D.compare_spec; try MD.order; simpl.
+ inversion_clear Hl.
+ inversion_clear Hl'.
+ destruct (IHl H (Mk H3)).
+ unfold equal, eq in H5; simpl in H5; auto.
+ destruct (andb_prop _ _ H); clear H.
+ generalize H0; unfold cmp.
+ elim D.compare_spec; try MD.order; simpl; try discriminate.
+ destruct (andb_prop _ _ H); clear H.
+ inversion_clear Hl.
+ inversion_clear Hl'.
+ destruct (IHl H (Mk H3)).
+ unfold equal, eq in H6; simpl in H6; auto.
+Qed.
+
+Lemma eq_spec m m' : eq m m' <-> Equivb cmp m m'.
+Proof.
+ now rewrite eq_equal, equal_spec.
+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_spec t0 t0) as [Hlt|Heq|Hlt]; auto.
+ - split. reflexivity. inversion_clear Hm. apply (IHm H).
+ - MapS.Raw.MX.order.
+ - MapS.Raw.MX.order.
+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_spec x x') as [Hlt|Heq|Hlt];
+ elim X.compare_spec; try MapS.Raw.MX.order; intuition.
+ inversion_clear Hm; inversion_clear Hm'.
+ apply (IHm H0 (Mk 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_spec x x') as [Hlt|Heq|Hlt];
+ destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt'];
+ elim X.compare_spec; try MapS.Raw.MX.order; intuition.
+ now transitivity e'.
+ inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
+ apply (IHm1 H1 (Mk H6) (Mk H8)); intuition.
+Qed.
+
+Instance eq_equiv : Equivalence eq.
+Proof. split; [exact eq_refl|exact eq_sym|exact eq_trans]. 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_spec x x') as [Hlt|Heq|Hlt];
+ destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt'];
+ elim X.compare_spec; try MapS.Raw.MX.order; intuition.
+ left; transitivity e'; auto.
+ left; MD.order.
+ left; MD.order.
+ right.
+ split.
+ transitivity e'; auto.
+ inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3.
+ apply (IHm1 H2 (Mk H6) (Mk H8)); intuition.
+Qed.
+
+Lemma lt_irrefl : forall m, ~ lt m m.
+Proof.
+ intros (m,Hm); induction m; unfold lt; simpl; auto.
+ destruct a.
+ destruct (X.compare_spec t0 t0) as [Hlt|Heq|Hlt]; auto.
+ - intuition. MD.order. inversion_clear Hm. now apply (IHm H0).
+ - MapS.Raw.MX.order.
+Qed.
+
+Instance lt_strorder : StrictOrder lt.
+Proof. split; [exact lt_irrefl|exact lt_trans]. Qed.
+
+Lemma lt_compat1 : forall m1 m1' m2, eq m1 m1' -> lt m1 m2 -> lt m1' m2.
+Proof.
+ intros (m1,Hm1); induction m1;
+ intros (m1',Hm1'); destruct m1';
+ intros (m2,Hm2); destruct m2; unfold eq, lt;
+ try destruct a as (x,e);
+ try destruct p as (x',e');
+ try destruct p0 as (x'',e''); try contradiction; simpl; auto.
+ destruct (X.compare_spec x x') as [Hlt|Heq|Hlt];
+ destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt'];
+ elim X.compare_spec; try MapS.Raw.MX.order; intuition.
+ left; MD.order.
+ right.
+ split.
+ MD.order.
+ inversion_clear Hm1; inversion_clear Hm1'; inversion_clear Hm2.
+ apply (IHm1 H0 (Mk H6) (Mk H8)); intuition.
+Qed.
+
+Lemma lt_compat2 : forall m1 m2 m2', eq m2 m2' -> lt m1 m2 -> lt m1 m2'.
+Proof.
+ intros (m1,Hm1); induction m1;
+ intros (m2,Hm2); destruct m2;
+ intros (m2',Hm2'); destruct m2'; unfold eq, lt;
+ try destruct a as (x,e);
+ try destruct p as (x',e');
+ try destruct p0 as (x'',e''); try contradiction; simpl; auto.
+ destruct (X.compare_spec x x') as [Hlt|Heq|Hlt];
+ destruct (X.compare_spec x' x'') as [Hlt'|Heq'|Hlt'];
+ elim X.compare_spec; try MapS.Raw.MX.order; intuition.
+ left; MD.order.
+ right.
+ split.
+ MD.order.
+ inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm2'.
+ apply (IHm1 H0 (Mk H6) (Mk H8)); intuition.
+Qed.
+
+Instance lt_compat : Proper (eq==>eq==>iff) lt.
+Proof.
+ intros m1 m1' H1 m2 m2' H2. split; intros.
+ now apply (lt_compat2 H2), (lt_compat1 H1).
+ symmetry in H1, H2.
+ now apply (lt_compat2 H2), (lt_compat1 H1).
+Qed.
+
+Ltac cmp_solve :=
+ unfold eq, lt; simpl; elim X.compare_spec; try Raw.MX.order; auto.
+
+Fixpoint compare_list m1 m2 := match m1, m2 with
+| nil, nil => Eq
+| nil, _ => Lt
+| _, nil => Gt
+| (k1,e1)::m1, (k2,e2)::m2 =>
+ match X.compare k1 k2 with
+ | Lt => Lt
+ | Gt => Gt
+ | Eq => match D.compare e1 e2 with
+ | Lt => Lt
+ | Gt => Gt
+ | Eq => compare_list m1 m2
+ end
+ end
+end.
+
+Definition compare m1 m2 := compare_list m1.(this) m2.(this).
+
+Lemma compare_spec : forall m1 m2, CompSpec eq lt m1 m2 (compare m1 m2).
+Proof.
+ unfold CompSpec.
+ intros (m1,Hm1)(m2,Hm2). unfold compare, eq, lt; simpl.
+ revert m2 Hm2.
+ induction m1 as [|(k1,e1) m1 IH1]; destruct m2 as [|(k2,e2) m2];
+ try constructor; simpl; intros; auto.
+ elim X.compare_spec; simpl; try constructor; auto; intros.
+ elim D.compare_spec; simpl; try constructor; auto; intros.
+ inversion_clear Hm1; inversion_clear Hm2.
+ destruct (IH1 H1 _ H3); simpl; try constructor; auto.
+ elim X.compare_spec; try Raw.MX.order. right. now split.
+ elim X.compare_spec; try Raw.MX.order. now left.
+ elim X.compare_spec; try Raw.MX.order; auto.
+Qed.
+
+End Make_ord.
diff --git a/theories/MMaps/MMapPositive.v b/theories/MMaps/MMapPositive.v
new file mode 100644
index 00000000..d3aab238
--- /dev/null
+++ b/theories/MMaps/MMapPositive.v
@@ -0,0 +1,698 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(** * MMapPositive : an implementation of MMapInterface for [positive] keys. *)
+
+Require Import Bool PeanoNat BinPos Orders OrdersEx OrdersLists MMapInterface.
+
+Set Implicit Arguments.
+Local Open Scope lazy_bool_scope.
+Local Open Scope positive_scope.
+Local Unset Elimination Schemes.
+
+(** This file is an adaptation to the [MMap] 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. *)
+
+(** Reverses the positive [y] and concatenate it with [x] *)
+
+Fixpoint rev_append (y x : positive) : positive :=
+ match y with
+ | 1 => x
+ | y~1 => rev_append y x~1
+ | y~0 => rev_append y x~0
+ end.
+Local Infix "@" := rev_append (at level 60).
+Definition rev x := x@1.
+
+(** 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.
+
+ Definition eq_key {A} (p p':key*A) := E.eq (fst p) (fst p').
+
+ Definition eq_key_elt {A} (p p':key*A) :=
+ E.eq (fst p) (fst p') /\ (snd p) = (snd p').
+
+ Definition lt_key {A} (p p':key*A) := E.lt (fst p) (fst p').
+
+ Instance eqk_equiv {A} : Equivalence (@eq_key A) := _.
+ Instance eqke_equiv {A} : Equivalence (@eq_key_elt A) := _.
+ Instance ltk_strorder {A} : StrictOrder (@lt_key A) := _.
+
+ Inductive tree (A : Type) :=
+ | Leaf : tree A
+ | Node : tree A -> option A -> tree A -> tree A.
+
+ Arguments Leaf {A}.
+
+ Scheme tree_ind := Induction for tree Sort Prop.
+
+ Definition t := tree.
+
+ Definition empty {A} : t A := Leaf.
+
+ Section A.
+ Variable A:Type.
+
+ 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.
+
+ (** helper function to avoid creating empty trees that are not leaves *)
+
+ Definition node (l : t A) (o: option A) (r : t A) : t A :=
+ match o,l,r with
+ | None,Leaf,Leaf => Leaf
+ | _,_,_ => Node l o r
+ end.
+
+ Fixpoint remove (i : key) (m : t A) : t A :=
+ match m with
+ | Leaf => Leaf
+ | Node l o r =>
+ match i with
+ | xH => node l None r
+ | xO ii => node (remove ii l) o r
+ | xI ii => node l o (remove ii r)
+ end
+ end.
+
+ (** [bindings] *)
+
+ Fixpoint xbindings (m : t A) (i : positive) (a: list (key*A)) :=
+ match m with
+ | Leaf => a
+ | Node l None r => xbindings l i~0 (xbindings r i~1 a)
+ | Node l (Some e) r => xbindings l i~0 ((rev i,e) :: xbindings r i~1 a)
+ end.
+
+ Definition bindings (m : t A) := xbindings m 1 nil.
+
+ (** [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.
+
+ (** Specification proofs *)
+
+ 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.
+
+ Lemma MapsTo_compat : Proper (E.eq==>eq==>eq==>iff) MapsTo.
+ Proof.
+ intros k k' Hk e e' He m m' Hm. red in Hk. now subst.
+ Qed.
+
+ Lemma find_spec m x e : find x m = Some e <-> MapsTo x e m.
+ Proof. reflexivity. Qed.
+
+ 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 mem_spec : forall m x, mem x m = true <-> In x m.
+ Proof.
+ unfold In, MapsTo; intros m x; rewrite mem_find.
+ split.
+ - destruct (find x m).
+ exists a; auto.
+ intros; discriminate.
+ - destruct 1 as (e0,H0); rewrite H0; auto.
+ Qed.
+
+ Lemma gleaf : forall (i : key), find i Leaf = None.
+ Proof. destruct i; simpl; auto. Qed.
+
+ Theorem empty_spec:
+ forall (i: key), find i empty = None.
+ Proof. exact gleaf. Qed.
+
+ Lemma is_empty_spec m :
+ is_empty m = true <-> forall k, find k m = None.
+ Proof.
+ induction m; simpl.
+ - intuition. apply empty_spec.
+ - destruct o. split; try discriminate.
+ intros H. now specialize (H xH).
+ rewrite <- andb_lazy_alt, andb_true_iff, IHm1, IHm2.
+ clear IHm1 IHm2.
+ split.
+ + intros (H1,H2) k. destruct k; simpl; auto.
+ + intros H; split; intros k. apply (H (xO k)). apply (H (xI k)).
+ Qed.
+
+ Theorem add_spec1:
+ forall (m: t A) (i: key) (x: A), find i (add i x m) = Some x.
+ Proof.
+ intros m i; revert m.
+ induction i; destruct m; simpl; auto.
+ Qed.
+
+ Theorem add_spec2:
+ forall (m: t A) (i j: key) (x: A),
+ i <> j -> find j (add i x m) = find j m.
+ Proof.
+ intros m i j; revert m i.
+ induction j; destruct i, m; simpl; intros;
+ rewrite ?IHj, ?gleaf; auto; try congruence.
+ Qed.
+
+ Lemma rleaf : forall (i : key), remove i Leaf = Leaf.
+ Proof. destruct i; simpl; auto. Qed.
+
+ Lemma gnode l o r i : find i (node l o r) = find i (Node l o r).
+ Proof.
+ destruct o,l,r; simpl; trivial.
+ destruct i; simpl; now rewrite ?gleaf.
+ Qed.
+
+ Opaque node.
+
+ Theorem remove_spec1:
+ forall (m: t A)(i: key), find i (remove i m) = None.
+ Proof.
+ induction m; simpl.
+ - intros; rewrite rleaf. apply gleaf.
+ - destruct i; simpl remove; rewrite gnode; simpl; auto.
+ Qed.
+
+ Theorem remove_spec2:
+ forall (m: t A)(i j: key),
+ i <> j -> find j (remove i m) = find j m.
+ Proof.
+ induction m; simpl; intros.
+ - now rewrite rleaf.
+ - destruct i; simpl; rewrite gnode; destruct j; simpl; trivial;
+ try apply IHm1; try apply IHm2; congruence.
+ Qed.
+
+ Local Notation InL := (InA eq_key_elt).
+
+ Lemma xbindings_spec: forall m j acc k e,
+ InL (k,e) (xbindings m j acc) <->
+ InL (k,e) acc \/ exists x, k=(j@x) /\ find x m = Some e.
+ Proof.
+ induction m as [|l IHl o r IHr]; simpl.
+ - intros. split; intro H.
+ + now left.
+ + destruct H as [H|[x [_ H]]]. assumption.
+ now rewrite gleaf in H.
+ - intros j acc k e. case o as [e'|];
+ rewrite IHl, ?InA_cons, IHr; clear IHl IHr; split.
+ + intros [[H|[H|H]]|H]; auto.
+ * unfold eq_key_elt, E.eq, fst, snd in H. destruct H as (->,<-).
+ right. now exists 1.
+ * destruct H as (x,(->,H)). right. now exists x~1.
+ * destruct H as (x,(->,H)). right. now exists x~0.
+ + intros [H|H]; auto.
+ destruct H as (x,(->,H)).
+ destruct x; simpl in *.
+ * left. right. right. now exists x.
+ * right. now exists x.
+ * left. left. injection H as ->. reflexivity.
+ + intros [[H|H]|H]; auto.
+ * destruct H as (x,(->,H)). right. now exists x~1.
+ * destruct H as (x,(->,H)). right. now exists x~0.
+ + intros [H|H]; auto.
+ destruct H as (x,(->,H)).
+ destruct x; simpl in *.
+ * left. right. now exists x.
+ * right. now exists x.
+ * discriminate.
+ 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 xbindings_sort m j acc :
+ sort lt_key acc ->
+ (forall x p, In x m -> InL p acc -> E.lt (j@x) (fst p)) ->
+ sort lt_key (xbindings m j acc).
+ Proof.
+ revert j acc.
+ induction m as [|l IHl o r IHr]; simpl; trivial.
+ intros j acc Hacc Hsacc. destruct o as [e|].
+ - apply IHl;[constructor;[apply IHr; [apply Hacc|]|]|].
+ + intros. now apply Hsacc.
+ + case_eq (xbindings r j~1 acc); [constructor|].
+ intros (z,e') q H. constructor.
+ assert (H': InL (z,e') (xbindings r j~1 acc)).
+ { rewrite H. now constructor. }
+ clear H q. rewrite xbindings_spec in H'.
+ destruct H' as [H'|H'].
+ * apply (Hsacc 1 (z,e')); trivial. now exists e.
+ * destruct H' as (x,(->,H)).
+ red. simpl. now apply lt_rev_append.
+ + intros x (y,e') Hx Hy. inversion_clear Hy.
+ rewrite H. simpl. now apply lt_rev_append.
+ rewrite xbindings_spec in H.
+ destruct H as [H|H].
+ * now apply Hsacc.
+ * destruct H as (z,(->,H)). simpl.
+ now apply lt_rev_append.
+ - apply IHl; [apply IHr; [apply Hacc|]|].
+ + intros. now apply Hsacc.
+ + intros x (y,e') Hx H. rewrite xbindings_spec in H.
+ destruct H as [H|H].
+ * now apply Hsacc.
+ * destruct H as (z,(->,H)). simpl.
+ now apply lt_rev_append.
+ Qed.
+
+ Lemma bindings_spec1 m k e :
+ InA eq_key_elt (k,e) (bindings m) <-> MapsTo k e m.
+ Proof.
+ unfold bindings, MapsTo. rewrite xbindings_spec.
+ split; [ intros [H|(y & H & H')] | intros IN ].
+ - inversion H.
+ - simpl in *. now subst.
+ - right. now exists k.
+ Qed.
+
+ Lemma bindings_spec2 m : sort lt_key (bindings m).
+ Proof.
+ unfold bindings.
+ apply xbindings_sort. constructor. inversion 2.
+ Qed.
+
+ Lemma bindings_spec2w m : NoDupA eq_key (bindings m).
+ Proof.
+ apply ME.Sort_NoDupA.
+ apply bindings_spec2.
+ Qed.
+
+ Lemma xbindings_length m j acc :
+ length (xbindings m j acc) = (cardinal m + length acc)%nat.
+ Proof.
+ revert j acc.
+ induction m; simpl; trivial; intros.
+ destruct o; simpl; rewrite IHm1; simpl; rewrite IHm2;
+ now rewrite ?Nat.add_succ_r, Nat.add_assoc.
+ Qed.
+
+ Lemma cardinal_spec m : cardinal m = length (bindings m).
+ Proof.
+ unfold bindings. rewrite xbindings_length. simpl.
+ symmetry. apply Nat.add_0_r.
+ Qed.
+
+ (** [map] and [mapi] *)
+
+ Variable B : Type.
+
+ Section Mapi.
+
+ Variable f : key -> option A -> option B.
+
+ Fixpoint xmapi (m : t A) (i : key) : t B :=
+ match m with
+ | Leaf => Leaf
+ | Node l o r => Node (xmapi l (i~0))
+ (f (rev i) o)
+ (xmapi r (i~1))
+ end.
+
+ End Mapi.
+
+ Definition mapi (f : key -> A -> B) m :=
+ xmapi (fun k => option_map (f k)) m 1.
+
+ Definition map (f : A -> B) m := mapi (fun _ => f) m.
+
+ End A.
+
+ Lemma xgmapi:
+ forall (A B: Type) (f: key -> option A -> option B) (i j : key) (m: t A),
+ (forall k, f k None = None) ->
+ find i (xmapi f m j) = f (j@i) (find i m).
+ Proof.
+ induction i; intros; destruct m; simpl; rewrite ?IHi; auto.
+ Qed.
+
+ Theorem mapi_spec0 :
+ 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. rewrite xgmapi; simpl; auto.
+ Qed.
+
+ Lemma mapi_spec :
+ forall (A B: Type) (f: key -> A -> B) (m: t A) (i:key),
+ exists j, E.eq j i /\
+ find i (mapi f m) = option_map (f j) (find i m).
+ Proof.
+ intros.
+ exists i. split. reflexivity. apply mapi_spec0.
+ Qed.
+
+ Lemma map_spec :
+ forall (elt elt':Type)(f:elt->elt')(m: t elt)(x:key),
+ find x (map f m) = option_map f (find x m).
+ Proof.
+ intros; unfold map. apply mapi_spec0.
+ Qed.
+
+ Section merge.
+ Variable A B C : Type.
+ Variable f : key -> option A -> option B -> option C.
+
+ Fixpoint xmerge (m1 : t A)(m2 : t B)(i:positive) : t C :=
+ match m1 with
+ | Leaf => xmapi (fun k => f k None) m2 i
+ | Node l1 o1 r1 =>
+ match m2 with
+ | Leaf => xmapi (fun k o => f k o None) m1 i
+ | Node l2 o2 r2 =>
+ Node (xmerge l1 l2 (i~0))
+ (f (rev i) o1 o2)
+ (xmerge r1 r2 (i~1))
+ end
+ end.
+
+ Lemma xgmerge: forall (i j: key)(m1:t A)(m2: t B),
+ (forall i, f i None None = None) ->
+ find i (xmerge m1 m2 j) = f (j@i) (find i m1) (find i m2).
+ Proof.
+ induction i; intros; destruct m1; destruct m2; simpl; auto;
+ rewrite ?xgmapi, ?IHi; simpl; auto.
+ Qed.
+
+ End merge.
+
+ Definition merge {A B C}(f:key->option A->option B->option C) m1 m2 :=
+ xmerge
+ (fun k o1 o2 => match o1,o2 with
+ | None,None => None
+ | _, _ => f k o1 o2
+ end)
+ m1 m2 xH.
+
+ Lemma merge_spec1 {A B C}(f:key->option A->option B->option C) :
+ forall m m' x,
+ In x m \/ In x m' ->
+ exists y, E.eq y x /\
+ find x (merge f m m') = f y (find x m) (find x m').
+ Proof.
+ intros. exists x. split. reflexivity.
+ unfold merge.
+ rewrite xgmerge; simpl; auto.
+ rewrite <- 2 mem_spec, 2 mem_find in H.
+ destruct (find x m); simpl; auto.
+ destruct (find x m'); simpl; auto. intuition discriminate.
+ Qed.
+
+ Lemma merge_spec2 {A B C}(f:key->option A->option B->option C) :
+ forall m m' x, In x (merge f m m') -> In x m \/ In x m'.
+ Proof.
+ intros.
+ rewrite <-mem_spec, mem_find in H.
+ unfold merge in H.
+ rewrite xgmerge in H; simpl; auto.
+ rewrite <- 2 mem_spec, 2 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.
+
+ (** 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 A) (v : B) (i : key) :=
+ match m with
+ | Leaf => v
+ | Node l (Some x) r =>
+ xfold r (f (rev i) x (xfold l v i~0)) i~1
+ | Node l None r =>
+ xfold r (xfold l v i~0) i~1
+ end.
+ Definition fold m i := xfold m i 1.
+
+ End Fold.
+
+ Lemma fold_spec :
+ forall {A}(m:t A){B}(i : B) (f : key -> A -> B -> B),
+ fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (bindings m) i.
+ Proof.
+ unfold fold, bindings. intros A m B i f. revert m i.
+ set (f' := fun a p => f (fst p) (snd p) a).
+ assert (H: forall m i j acc,
+ fold_left f' acc (xfold f m i j) =
+ fold_left f' (xbindings m j acc) i).
+ { induction m as [|l IHl o r IHr]; intros; trivial.
+ destruct o; simpl; now rewrite IHr, <- IHl. }
+ intros. exact (H m i 1 nil).
+ 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 as (E,_); simpl.
+ apply is_empty_spec; intros k.
+ destruct (find k m') eqn:F; trivial.
+ assert (H : In k m') by now exists a.
+ rewrite <- E in H.
+ destruct H as (x,H). red in H. now rewrite gleaf in H.
+ - (* m = Node *)
+ destruct m'.
+ + (* m' = Leaf *)
+ destruct 1 as (E,_); simpl.
+ destruct o.
+ * assert (H : In xH (@Leaf A)).
+ { rewrite <- E. now exists a. }
+ destruct H as (e,H). now red in H.
+ * apply andb_true_intro; split; apply is_empty_spec; intros k.
+ destruct (find k m1) eqn:F; trivial.
+ assert (H : In (xO k) (@Leaf A)).
+ { rewrite <- E. exists a; auto. }
+ destruct H as (x,H). red in H. now rewrite gleaf in H.
+ destruct (find k m2) eqn:F; trivial.
+ assert (H : In (xI k) (@Leaf A)).
+ { rewrite <- E. exists a; auto. }
+ destruct H as (x,H). red in H. now rewrite gleaf in H.
+ + (* 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.
+ rewrite is_empty_spec in H.
+ intros (e,H'). red in H'. now rewrite H in H'.
+ 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.
+ rewrite is_empty_spec in H1.
+ now rewrite H1 in H.
+ rewrite is_empty_spec in H0.
+ now rewrite H0 in 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.
+
+ Lemma equal_spec : forall (A:Type)(m m':t A)(cmp:A->A->bool),
+ equal cmp m m' = true <-> Equivb cmp m m'.
+ Proof.
+ split. apply equal_2. apply equal_1.
+ Qed.
+
+End PositiveMap.
+
+(** Here come some additionnal facts about this implementation.
+ Most are facts that cannot be derivable from the general interface. *)
+
+Module PositiveMapAdditionalFacts.
+ Import PositiveMap.
+
+ (* Derivable from the Map interface *)
+ Theorem gsspec {A} i j x (m: t A) :
+ find i (add j x m) = if E.eq_dec i j then Some x else find i m.
+ Proof.
+ destruct (E.eq_dec i j) as [->|];
+ [ apply add_spec1 | apply add_spec2; auto ].
+ Qed.
+
+ (* Not derivable from the Map interface *)
+ Theorem gsident {A} i (m:t A) v :
+ find i m = Some v -> add i v m = m.
+ Proof.
+ revert m.
+ induction i; destruct m; simpl in *; try congruence.
+ - intro H; now rewrite (IHi m2 H).
+ - intro H; now rewrite (IHi m1 H).
+ Qed.
+
+ Lemma xmapi_ext {A B}(f g: key -> option A -> option B) :
+ (forall k (o : option A), f k o = g k o) ->
+ forall m i, xmapi f m i = xmapi g m i.
+ Proof.
+ induction m; intros; simpl; auto. now f_equal.
+ Qed.
+
+ Theorem xmerge_commut{A B C}
+ (f: key -> option A -> option B -> option C)
+ (g: key -> option B -> option A -> option C) :
+ (forall k o1 o2, f k o1 o2 = g k o2 o1) ->
+ forall m1 m2 i, xmerge f m1 m2 i = xmerge g m2 m1 i.
+ Proof.
+ intros E.
+ induction m1; destruct m2; intros i; simpl; trivial; f_equal;
+ try apply IHm1_1; try apply IHm1_2; try apply xmapi_ext;
+ intros; apply E.
+ Qed.
+
+ Theorem merge_commut{A B C}
+ (f: key -> option A -> option B -> option C)
+ (g: key -> option B -> option A -> option C) :
+ (forall k o1 o2, f k o1 o2 = g k o2 o1) ->
+ forall m1 m2, merge f m1 m2 = merge g m2 m1.
+ Proof.
+ intros E m1 m2.
+ unfold merge. apply xmerge_commut.
+ intros k [x1|] [x2|]; trivial.
+ Qed.
+
+End PositiveMapAdditionalFacts.
diff --git a/theories/MMaps/MMapWeakList.v b/theories/MMaps/MMapWeakList.v
new file mode 100644
index 00000000..656c61e1
--- /dev/null
+++ b/theories/MMaps/MMapWeakList.v
@@ -0,0 +1,687 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+(** * Finite map library *)
+
+(** This file proposes an implementation of the non-dependant interface
+ [MMapInterface.WS] using lists of pairs, unordered but without redundancy. *)
+
+Require Import MMapInterface EqualitiesFacts.
+
+Set Implicit Arguments.
+Unset Strict Implicit.
+
+Lemma Some_iff {A} (a a' : A) : Some a = Some a' <-> a = a'.
+Proof. split; congruence. Qed.
+
+Module Raw (X:DecidableType).
+
+Module Import PX := KeyDecidableType X.
+
+Definition key := X.t.
+Definition t (elt:Type) := list (X.t * elt).
+
+Ltac dec := match goal with
+ | |- context [ X.eq_dec ?x ?x ] =>
+ let E := fresh "E" in destruct (X.eq_dec x x) as [E|E]; [ | now elim E]
+ | H : X.eq ?x ?y |- context [ X.eq_dec ?x ?y ] =>
+ let E := fresh "E" in destruct (X.eq_dec x y) as [_|E]; [ | now elim E]
+ | H : ~X.eq ?x ?y |- context [ X.eq_dec ?x ?y ] =>
+ let E := fresh "E" in destruct (X.eq_dec x y) as [E|_]; [ now elim H | ]
+ | |- context [ X.eq_dec ?x ?y ] =>
+ let E := fresh "E" in destruct (X.eq_dec x y) as [E|E]
+end.
+
+Section Elt.
+
+Variable elt : Type.
+Notation NoDupA := (@NoDupA _ eqk).
+
+(** * [find] *)
+
+Fixpoint find (k:key) (s: t elt) : 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_spec : forall m (Hm:NoDupA m) x e,
+ find x m = Some e <-> MapsTo x e m.
+Proof.
+ unfold PX.MapsTo.
+ induction m as [ | (k,e) m IH]; simpl.
+ - split; inversion 1.
+ - intros Hm k' e'. rewrite InA_cons.
+ change (eqke (k',e') (k,e)) with (X.eq k' k /\ e' = e).
+ inversion_clear Hm. dec.
+ + rewrite Some_iff; intuition.
+ elim H. apply InA_eqk with (k',e'); auto.
+ + rewrite IH; intuition.
+Qed.
+
+(** * [mem] *)
+
+Fixpoint mem (k : key) (s : t elt) : bool :=
+ match s with
+ | nil => false
+ | (k',_) :: l => if X.eq_dec k k' then true else mem k l
+ end.
+
+Lemma mem_spec : forall m (Hm:NoDupA m) x, mem x m = true <-> In x m.
+Proof.
+ induction m as [ | (k,e) m IH]; simpl; intros Hm x.
+ - split. discriminate. inversion_clear 1. inversion H0.
+ - inversion_clear Hm. rewrite PX.In_cons; simpl.
+ rewrite <- IH by trivial.
+ dec; intuition.
+Qed.
+
+(** * [empty] *)
+
+Definition empty : t elt := nil.
+
+Lemma empty_spec x : find x empty = None.
+Proof.
+ reflexivity.
+Qed.
+
+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_spec m : is_empty m = true <-> forall x, find x m = None.
+Proof.
+ destruct m; simpl; intuition; try discriminate.
+ specialize (H a).
+ revert H. now dec.
+Qed.
+
+(* Not part of the exported specifications, used later for [merge]. *)
+
+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.
+ dec; dec; trivial.
+ elim E0. now transitivity x.
+ elim E. now transitivity x'.
+Qed.
+
+(** * [add] *)
+
+Fixpoint add (k : key) (x : elt) (s : t elt) : 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_spec1 m x e : find x (add x e m) = Some e.
+Proof.
+ induction m as [ | (k,e') m IH]; simpl.
+ - now dec.
+ - dec; simpl; now dec.
+Qed.
+
+Lemma add_spec2 m x y e : ~X.eq x y -> find y (add x e m) = find y m.
+Proof.
+ intros N.
+ assert (N' : ~X.eq y x) by now contradict N.
+ induction m as [ | (k,e') m IH]; simpl.
+ - dec; trivial.
+ - repeat (dec; simpl); trivial. elim N. now transitivity k.
+Qed.
+
+Lemma add_InA : forall m x y e e',
+ ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m.
+Proof.
+ induction m as [ | (k,e') m IH]; simpl; intros.
+ - inversion_clear H0. elim H. symmetry; apply H1. inversion_clear H1.
+ - revert H0; dec; rewrite !InA_cons.
+ + rewrite E. intuition.
+ + intuition. right; eapply IH; eauto.
+Qed.
+
+Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m).
+Proof.
+ induction m as [ | (k,e') m IH]; simpl; intros Hm x e.
+ - constructor; auto. now inversion 1.
+ - inversion_clear Hm. dec; constructor; auto.
+ + contradict H. apply InA_eqk with (x,e); auto.
+ + contradict H; apply add_InA with x e; auto.
+Qed.
+
+(** * [remove] *)
+
+Fixpoint remove (k : key) (s : t elt) : 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_spec1 m (Hm: NoDupA m) x : find x (remove x m) = None.
+Proof.
+ induction m as [ | (k,e') m IH]; simpl; trivial.
+ inversion_clear Hm.
+ repeat (dec; simpl); auto.
+ destruct (find x m) eqn:F; trivial.
+ apply find_spec in F; trivial.
+ elim H. apply InA_eqk with (x,e); auto.
+Qed.
+
+Lemma remove_spec2 m (Hm: NoDupA m) x y : ~X.eq x y ->
+ find y (remove x m) = find y m.
+Proof.
+ induction m as [ | (k,e') m IH]; simpl; trivial; intros E.
+ inversion_clear Hm.
+ repeat (dec; simpl); auto.
+ elim E. now transitivity k.
+Qed.
+
+Lemma remove_InA : forall m (Hm:NoDupA m) x y e,
+ InA eqk (y,e) (remove x m) -> InA eqk (y,e) m.
+Proof.
+ induction m as [ | (k,e') m IH]; simpl; trivial; intros.
+ inversion_clear Hm.
+ revert H; dec; rewrite !InA_cons; intuition.
+ right; eapply H; eauto.
+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_InA with x; auto.
+Qed.
+
+(** * [bindings] *)
+
+Definition bindings (m: t elt) := m.
+
+Lemma bindings_spec1 m x e : InA eqke (x,e) (bindings m) <-> MapsTo x e m.
+Proof.
+ reflexivity.
+Qed.
+
+Lemma bindings_spec2w m (Hm:NoDupA m) : NoDupA (bindings m).
+Proof.
+ trivial.
+Qed.
+
+(** * [fold] *)
+
+Fixpoint fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) : A :=
+ match m with
+ | nil => acc
+ | (k,e)::m' => fold f m' (f k e acc)
+ end.
+
+Lemma fold_spec : 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) (bindings m) i.
+Proof.
+ induction m as [ | (k,e) m IH]; simpl; 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:elt->elt->bool) m m' :=
+ (forall k, In k m -> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
+
+Definition Equivb (cmp:elt->elt->bool) m m' :=
+ (forall k, In k m <-> In k m') /\
+ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true).
+
+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 with *. }
+ destruct H3 as (e', H3).
+ assert (H4 : find t0 m' = Some e') by now apply find_spec.
+ unfold check at 2. rewrite H4.
+ rewrite (H0 t0); simpl; auto with *.
+ eapply IHm; auto.
+ split; intuition.
+ apply H.
+ destruct H6 as (e'',H6); 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 with *.
+ apply find_spec; auto.
+ apply H3.
+ exists e0; auto.
+ inversion_clear H6.
+ compute in H8; destruct H8; subst.
+ assert (H8 : MapsTo t0 e'0 m'). { eapply PX.MapsTo_eq; eauto. }
+ apply find_spec in H8; trivial. congruence.
+ apply H4 with k; auto.
+Qed.
+
+(** Specification of [equal] *)
+
+Lemma equal_spec : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp,
+ equal cmp m m' = true <-> Equivb cmp m m'.
+Proof.
+ unfold Equivb, equal.
+ split.
+ - intros.
+ destruct (andb_prop _ _ H); clear H.
+ generalize (submap_2 Hm Hm' H0).
+ generalize (submap_2 Hm' Hm H1).
+ firstorder.
+ - intuition.
+ apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder.
+Qed.
+End Elt.
+Section Elt2.
+Variable elt 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.
+
+(** Specification of [map] *)
+
+Lemma map_spec (f:elt->elt')(m:t elt)(x:key) :
+ find x (map f m) = option_map f (find x m).
+Proof.
+ induction m as [ | (k,e) m IH]; simpl; trivial.
+ dec; simpl; trivial.
+Qed.
+
+Lemma map_NoDup 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.
+ clear IHm H0.
+ induction m; simpl in *; auto.
+ inversion H.
+ destruct a; inversion H; auto.
+Qed.
+
+(** Specification of [mapi] *)
+
+Lemma mapi_spec (f:key->elt->elt')(m:t elt)(x:key) :
+ exists y, X.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+Proof.
+ induction m as [ | (k,e) m IH]; simpl; trivial.
+ - now exists x.
+ - dec; simpl.
+ + now exists k.
+ + destruct IH as (y,(Hy,H)). now exists y.
+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.
+
+Lemma mapfst_InA {elt}(m:t elt) x :
+ InA X.eq x (List.map fst m) <-> In x m.
+Proof.
+ induction m as [| (k,e) m IH]; simpl; auto.
+ - split; inversion 1. inversion H0.
+ - rewrite InA_cons, In_cons. simpl. now rewrite IH.
+Qed.
+
+Lemma mapfst_NoDup {elt}(m:t elt) :
+ NoDupA X.eq (List.map fst m) <-> NoDupA eqk m.
+Proof.
+ induction m as [| (k,e) m IH]; simpl.
+ - split; constructor.
+ - split; inversion_clear 1; constructor; try apply IH; trivial.
+ + contradict H0. rewrite mapfst_InA. eapply In_alt'; eauto.
+ + rewrite mapfst_InA. contradict H0. now apply In_alt'.
+Qed.
+
+Lemma filter_NoDup f (m:list key) :
+ NoDupA X.eq m -> NoDupA X.eq (List.filter f m).
+Proof.
+ induction 1; simpl.
+ - constructor.
+ - destruct (f x); trivial. constructor; trivial.
+ contradict H. rewrite InA_alt in *. destruct H as (y,(Hy,H)).
+ exists y; split; trivial. now rewrite filter_In in H.
+Qed.
+
+Lemma NoDupA_unique_repr (l:list key) x y :
+ NoDupA X.eq l -> X.eq x y -> List.In x l -> List.In y l -> x = y.
+Proof.
+ intros H E Hx Hy.
+ induction H; simpl in *.
+ - inversion Hx.
+ - intuition; subst; trivial.
+ elim H. apply InA_alt. now exists y.
+ elim H. apply InA_alt. now exists x.
+Qed.
+
+Section Elt3.
+
+Variable elt elt' elt'' : Type.
+
+Definition restrict (m:t elt)(k:key) :=
+ match find k m with
+ | None => true
+ | Some _ => false
+ end.
+
+Definition domains (m:t elt)(m':t elt') :=
+ List.map fst m ++ List.filter (restrict m) (List.map fst m').
+
+Lemma domains_InA m m' (Hm : NoDupA eqk m) x :
+ InA X.eq x (domains m m') <-> In x m \/ In x m'.
+Proof.
+ unfold domains.
+ assert (Proper (X.eq==>eq) (restrict m)).
+ { intros k k' Hk. unfold restrict. now rewrite (find_eq Hm Hk). }
+ rewrite InA_app_iff, filter_InA, !mapfst_InA; intuition.
+ unfold restrict.
+ destruct (find x m) eqn:F.
+ - left. apply find_spec in F; trivial. now exists e.
+ - now right.
+Qed.
+
+Lemma domains_NoDup m m' : NoDupA eqk m -> NoDupA eqk m' ->
+ NoDupA X.eq (domains m m').
+Proof.
+ intros Hm Hm'. unfold domains.
+ apply NoDupA_app; auto with *.
+ - now apply mapfst_NoDup.
+ - now apply filter_NoDup, mapfst_NoDup.
+ - intros x.
+ rewrite mapfst_InA. intros (e,H).
+ apply find_spec in H; trivial.
+ rewrite InA_alt. intros (y,(Hy,H')).
+ rewrite (find_eq Hm Hy) in H.
+ rewrite filter_In in H'. destruct H' as (_,H').
+ unfold restrict in H'. now rewrite H in H'.
+Qed.
+
+Fixpoint fold_keys (f:key->option elt'') l :=
+ match l with
+ | nil => nil
+ | k::l =>
+ match f k with
+ | Some e => (k,e)::fold_keys f l
+ | None => fold_keys f l
+ end
+ end.
+
+Lemma fold_keys_In f l x e :
+ List.In (x,e) (fold_keys f l) <-> List.In x l /\ f x = Some e.
+Proof.
+ induction l as [|k l IH]; simpl.
+ - intuition.
+ - destruct (f k) eqn:F; simpl; rewrite IH; clear IH; intuition;
+ try left; congruence.
+Qed.
+
+Lemma fold_keys_NoDup f l :
+ NoDupA X.eq l -> NoDupA eqk (fold_keys f l).
+Proof.
+ induction 1; simpl.
+ - constructor.
+ - destruct (f x); trivial.
+ constructor; trivial. contradict H.
+ apply InA_alt in H. destruct H as ((k,e'),(E,H)).
+ rewrite fold_keys_In in H.
+ apply InA_alt. exists k. now split.
+Qed.
+
+Variable f : key -> option elt -> option elt' -> option elt''.
+
+Definition merge m m' : t elt'' :=
+ fold_keys (fun k => f k (find k m) (find k m')) (domains m m').
+
+Lemma merge_NoDup m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m') :
+ NoDupA (@eqk elt'') (merge m m').
+Proof.
+ now apply fold_keys_NoDup, domains_NoDup.
+Qed.
+
+Lemma merge_spec1 m (Hm:NoDupA eqk m) m' (Hm':NoDupA eqk m') x :
+ In x m \/ In x m' ->
+ exists y:key, X.eq y x /\
+ find x (merge m m') = f y (find x m) (find x m').
+Proof.
+ assert (Hmm' : NoDupA eqk (merge m m')) by now apply merge_NoDup.
+ rewrite <- domains_InA; trivial.
+ rewrite InA_alt. intros (y,(Hy,H)).
+ exists y; split; [easy|].
+ rewrite (find_eq Hm Hy), (find_eq Hm' Hy).
+ destruct (f y (find y m) (find y m')) eqn:F.
+ - apply find_spec; trivial.
+ red. apply InA_alt. exists (y,e). split. now split.
+ unfold merge. apply fold_keys_In. now split.
+ - destruct (find x (merge m m')) eqn:F'; trivial.
+ rewrite <- F; clear F. symmetry.
+ apply find_spec in F'; trivial.
+ red in F'. rewrite InA_alt in F'.
+ destruct F' as ((y',e'),(E,F')).
+ unfold merge in F'; rewrite fold_keys_In in F'.
+ destruct F' as (H',F').
+ compute in E; destruct E as (Hy',<-).
+ replace y with y'; trivial.
+ apply (@NoDupA_unique_repr (domains m m')); auto.
+ now apply domains_NoDup.
+ now transitivity x.
+Qed.
+
+Lemma merge_spec2 m (Hm:NoDupA eqk m) m' (Hm':NoDupA eqk m') x :
+ In x (merge m m') -> In x m \/ In x m'.
+Proof.
+ rewrite <- domains_InA; trivial.
+ intros (e,H). red in H. rewrite InA_alt in H. destruct H as ((k,e'),(E,H)).
+ unfold merge in H; rewrite fold_keys_In in H. destruct H as (H,_).
+ apply InA_alt. exists k. split; trivial. now destruct E.
+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.
+ Definition eq_key {elt} := @Raw.PX.eqk elt.
+ Definition eq_key_elt {elt} := @Raw.PX.eqke elt.
+
+ Record t_ (elt:Type) := Mk
+ {this :> Raw.t elt;
+ nodup : NoDupA Raw.PX.eqk this}.
+ Definition t := t_.
+
+ Definition empty {elt} : t elt := Mk (Raw.empty_NoDup elt).
+
+Section Elt.
+ Variable elt elt' elt'':Type.
+ Implicit Types m : t elt.
+ Implicit Types x y : key.
+ Implicit Types e : elt.
+
+ Definition find x m : option elt := Raw.find x m.(this).
+ Definition mem x m : bool := Raw.mem x m.(this).
+ Definition is_empty m : bool := Raw.is_empty m.(this).
+ Definition add x e m : t elt := Mk (Raw.add_NoDup m.(nodup) x e).
+ Definition remove x m : t elt := Mk (Raw.remove_NoDup m.(nodup) x).
+ Definition map f m : t elt' := Mk (Raw.map_NoDup m.(nodup) f).
+ Definition mapi (f:key->elt->elt') m : t elt' :=
+ Mk (Raw.mapi_NoDup m.(nodup) f).
+ Definition merge f m (m':t elt') : t elt'' :=
+ Mk (Raw.merge_NoDup f m.(nodup) m'.(nodup)).
+ Definition bindings m : list (key*elt) := Raw.bindings m.(this).
+ Definition cardinal m := length m.(this).
+ Definition fold {A}(f:key->elt->A->A) m (i:A) : A := Raw.fold f m.(this) i.
+ Definition equal cmp m m' : bool := Raw.equal cmp m.(this) m'.(this).
+ Definition MapsTo x e m : Prop := Raw.PX.MapsTo x e m.(this).
+ Definition In x m : Prop := Raw.PX.In x m.(this).
+
+ Definition 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 cmp m.(this) m'.(this).
+
+ Instance MapsTo_compat :
+ Proper (E.eq==>Logic.eq==>Logic.eq==>iff) MapsTo.
+ Proof.
+ intros x x' Hx e e' <- m m' <-. unfold MapsTo. now rewrite Hx.
+ Qed.
+
+ Lemma find_spec m : forall x e, find x m = Some e <-> MapsTo x e m.
+ Proof. exact (Raw.find_spec m.(nodup)). Qed.
+
+ Lemma mem_spec m : forall x, mem x m = true <-> In x m.
+ Proof. exact (Raw.mem_spec m.(nodup)). Qed.
+
+ Lemma empty_spec : forall x, find x empty = None.
+ Proof. exact (Raw.empty_spec _). Qed.
+
+ Lemma is_empty_spec m : is_empty m = true <-> (forall x, find x m = None).
+ Proof. exact (Raw.is_empty_spec m.(this)). Qed.
+
+ Lemma add_spec1 m : forall x e, find x (add x e m) = Some e.
+ Proof. exact (Raw.add_spec1 m.(this)). Qed.
+ Lemma add_spec2 m : forall x y e, ~E.eq x y -> find y (add x e m) = find y m.
+ Proof. exact (Raw.add_spec2 m.(this)). Qed.
+
+ Lemma remove_spec1 m : forall x, find x (remove x m) = None.
+ Proof. exact (Raw.remove_spec1 m.(nodup)). Qed.
+ Lemma remove_spec2 m : forall x y, ~E.eq x y -> find y (remove x m) = find y m.
+ Proof. exact (Raw.remove_spec2 m.(nodup)). Qed.
+
+ Lemma bindings_spec1 m : forall x e,
+ InA eq_key_elt (x,e) (bindings m) <-> MapsTo x e m.
+ Proof. exact (Raw.bindings_spec1 m.(this)). Qed.
+ Lemma bindings_spec2w m : NoDupA eq_key (bindings m).
+ Proof. exact (Raw.bindings_spec2w m.(nodup)). Qed.
+
+ Lemma cardinal_spec m : cardinal m = length (bindings m).
+ Proof. reflexivity. Qed.
+
+ Lemma fold_spec m : 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) (bindings m) i.
+ Proof. exact (Raw.fold_spec m.(this)). Qed.
+
+ Lemma equal_spec m m' : forall cmp, equal cmp m m' = true <-> Equivb cmp m m'.
+ Proof. exact (Raw.equal_spec m.(nodup) m'.(nodup)). Qed.
+
+End Elt.
+
+ Lemma map_spec {elt elt'} (f:elt->elt') m :
+ forall x, find x (map f m) = option_map f (find x m).
+ Proof. exact (Raw.map_spec f m.(this)). Qed.
+
+ Lemma mapi_spec {elt elt'} (f:key->elt->elt') m :
+ forall x, exists y,
+ E.eq y x /\ find x (mapi f m) = option_map (f y) (find x m).
+ Proof. exact (Raw.mapi_spec f m.(this)). Qed.
+
+ Lemma merge_spec1 {elt elt' elt''}
+ (f:key->option elt->option elt'->option elt'') m m' :
+ forall x,
+ In x m \/ In x m' ->
+ exists y, E.eq y x /\ find x (merge f m m') = f y (find x m) (find x m').
+ Proof. exact (Raw.merge_spec1 f m.(nodup) m'.(nodup)). Qed.
+
+ Lemma merge_spec2 {elt elt' elt''}
+ (f:key->option elt->option elt'->option elt'') m m' :
+ forall x,
+ In x (merge f m m') -> In x m \/ In x m'.
+ Proof. exact (Raw.merge_spec2 m.(nodup) m'.(nodup)). Qed.
+
+End Make.
diff --git a/theories/MMaps/MMaps.v b/theories/MMaps/MMaps.v
new file mode 100644
index 00000000..054d0722
--- /dev/null
+++ b/theories/MMaps/MMaps.v
@@ -0,0 +1,16 @@
+(***********************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *)
+(* \VV/ *************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(***********************************************************************)
+
+
+Require Export Orders OrdersEx OrdersAlt.
+Require Export Equalities.
+Require Export MMapInterface.
+Require Export MMapFacts.
+Require Export MMapWeakList.
+Require Export MMapList.
+Require Export MMapPositive.
diff --git a/theories/MMaps/vo.itarget b/theories/MMaps/vo.itarget
new file mode 100644
index 00000000..a7bbd266
--- /dev/null
+++ b/theories/MMaps/vo.itarget
@@ -0,0 +1,7 @@
+MMapInterface.vo
+MMapFacts.vo
+MMapWeakList.vo
+MMapList.vo
+MMapPositive.vo
+MMaps.vo
+MMapAVL.vo \ No newline at end of file
diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v
index e1fc454a..cc023cc3 100644
--- a/theories/MSets/MSetAVL.v
+++ b/theories/MSets/MSetAVL.v
@@ -31,7 +31,7 @@
code after extraction.
*)
-Require Import MSetInterface MSetGenTree ZArith Int.
+Require Import MSetInterface MSetGenTree BinInt Int.
Set Implicit Arguments.
Unset Strict Implicit.
@@ -83,11 +83,11 @@ Definition assert_false := create.
Definition bal l x r :=
let hl := height l in
let hr := height r in
- if gt_le_dec hl (hr+2) then
+ if (hr+2) <? hl then
match l with
| Leaf => assert_false l x r
| Node _ ll lx lr =>
- if ge_lt_dec (height ll) (height lr) then
+ if (height lr) <=? (height ll) then
create ll lx (create lr x r)
else
match lr with
@@ -97,11 +97,11 @@ Definition bal l x r :=
end
end
else
- if gt_le_dec hr (hl+2) then
+ if (hl+2) <? hr then
match r with
| Leaf => assert_false l x r
| Node _ rl rx rr =>
- if ge_lt_dec (height rr) (height rl) then
+ if (height rl) <=? (height rr) then
create (create l x rl) rx rr
else
match rl with
@@ -138,8 +138,8 @@ Fixpoint join l : elt -> t -> t :=
fix join_aux (r:t) : t := match r with
| Leaf => add x l
| Node rh rl rx rr =>
- if gt_le_dec lh (rh+2) then bal ll lx (join lr x r)
- else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr
+ if (rh+2) <? lh then bal ll lx (join lr x r)
+ else if (lh+2) <? rh then bal (join_aux rl) rx rr
else create l x r
end
end.
@@ -419,12 +419,12 @@ Local Open Scope Int_scope.
Ltac join_tac :=
intro l; induction l as [| lh ll _ lx lr Hlr];
[ | intros x r; induction r as [| rh rl Hrl rx rr _]; unfold join;
- [ | destruct (gt_le_dec lh (rh+2)) as [GT|LE];
+ [ | destruct ((rh+2) <? lh) eqn:LT;
[ match goal with |- context b [ bal ?a ?b ?c] =>
replace (bal a b c)
with (bal ll lx (join lr x (Node rh rl rx rr))); [ | auto]
end
- | destruct (gt_le_dec rh (lh+2)) as [GT'|LE'];
+ | destruct ((lh+2) <? rh) eqn:LT';
[ match goal with |- context b [ bal ?a ?b ?c] =>
replace (bal a b c)
with (bal (join (Node lh ll lx lr) x rl) rx rr); [ | auto]
diff --git a/theories/MSets/MSetPositive.v b/theories/MSets/MSetPositive.v
index 25a8c162..8dd240f4 100644
--- a/theories/MSets/MSetPositive.v
+++ b/theories/MSets/MSetPositive.v
@@ -16,79 +16,13 @@
Sandrine Blazy (used for building certified compilers).
*)
-Require Import Bool BinPos Orders MSetInterface.
+Require Import Bool BinPos Orders OrdersEx MSetInterface.
Set Implicit Arguments.
Local Open Scope lazy_bool_scope.
Local Open Scope positive_scope.
Local Unset Elimination Schemes.
-(** Even if [positive] can be seen as an ordered type with respect to the
- usual order (see above), we can also use a lexicographic order over bits
- (lower bits are considered first). This is more natural when using
- [positive] as indexes for sets or maps (see FSetPositive and FMapPositive. *)
-
-Module PositiveOrderedTypeBits <: UsualOrderedType.
- Definition t:=positive.
- Include HasUsualEq <+ UsualIsEq.
- Definition eqb := Pos.eqb.
- Definition eqb_eq := Pos.eqb_eq.
- Include HasEqBool2Dec.
-
- Fixpoint bits_lt (p q:positive) : Prop :=
- match p, q with
- | xH, xI _ => True
- | xH, _ => False
- | xO p, xO q => bits_lt p q
- | xO _, _ => True
- | xI p, xI q => bits_lt p q
- | xI _, _ => False
- end.
-
- Definition lt:=bits_lt.
-
- Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
- Proof.
- induction x; simpl; auto.
- Qed.
-
- Lemma bits_lt_trans :
- forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
- Proof.
- induction x; destruct y,z; simpl; eauto; intuition.
- Qed.
-
- Instance lt_compat : Proper (eq==>eq==>iff) lt.
- Proof.
- intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition.
- Qed.
-
- Instance lt_strorder : StrictOrder lt.
- Proof.
- split; [ exact bits_lt_antirefl | exact bits_lt_trans ].
- Qed.
-
- Fixpoint compare x y :=
- match x, y with
- | x~1, y~1 => compare x y
- | x~1, _ => Gt
- | x~0, y~0 => compare x y
- | x~0, _ => Lt
- | 1, y~1 => Lt
- | 1, 1 => Eq
- | 1, y~0 => Gt
- end.
-
- Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
- Proof.
- unfold eq, lt.
- induction x; destruct y; try constructor; simpl; auto.
- destruct (IHx y); subst; auto.
- destruct (IHx y); subst; auto.
- Qed.
-
-End PositiveOrderedTypeBits.
-
Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
Module E:=PositiveOrderedTypeBits.
@@ -303,12 +237,6 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
| 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 :=
@@ -316,7 +244,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
| Leaf => None
| Node l o r => if o then Some 1 else
match choose l with
- | None => omap xI (choose r)
+ | None => option_map xI (choose r)
| Some i => Some i~0
end
end.
@@ -326,7 +254,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
| Leaf => None
| Node l o r =>
match min_elt l with
- | None => if o then Some 1 else omap xI (min_elt r)
+ | None => if o then Some 1 else option_map xI (min_elt r)
| Some i => Some i~0
end
end.
@@ -336,7 +264,7 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
| Leaf => None
| Node l o r =>
match max_elt r with
- | None => if o then Some 1 else omap xO (max_elt l)
+ | None => if o then Some 1 else option_map xO (max_elt l)
| Some i => Some i~1
end
end.
@@ -967,7 +895,6 @@ Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits.
Lemma elements_spec2w: forall s, NoDupA E.eq (elements s).
Proof.
intro. apply SortA_NoDupA with E.lt; auto with *.
- apply E.eq_equiv.
apply elements_spec2.
Qed.
diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v
index a9aa30df..ae6fe7dd 100644
--- a/theories/Program/Equality.v
+++ b/theories/Program/Equality.v
@@ -426,8 +426,9 @@ Ltac depind id := do_depind ltac:(fun hyp => do_ind hyp) id.
(** A variant where generalized variables should be given by the user. *)
Ltac do_depelim' rev tac H :=
- (try intros until H) ; block_goal ; rev H ;
- (try revert_until H ; block_goal) ; generalize_eqs H ; tac H ; simpl_dep_elim.
+ (try intros until H) ; block_goal ;
+ (try revert_until H ; block_goal) ;
+ generalize_eqs H ; rev H ; tac H ; simpl_dep_elim.
(** Calls [destruct] on the generalized hypothesis, results should be similar to inversion.
By default, we don't try to generalize the hyp by its variable indices. *)
@@ -463,3 +464,9 @@ Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) :
Tactic Notation "dependent" "induction" ident(H) "generalizing" ne_hyp_list(l) "using" constr(c) :=
do_depelim' ltac:(fun hyp => revert l) ltac:(fun hyp => induction hyp using c) H.
+
+Tactic Notation "dependent" "induction" ident(H) "in" ne_hyp_list(l) :=
+ do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => induction hyp in l) H.
+
+Tactic Notation "dependent" "induction" ident(H) "in" ne_hyp_list(l) "using" constr(c) :=
+ do_depelim' ltac:(fun hyp => idtac) ltac:(fun hyp => induction hyp in l using c) H.
diff --git a/theories/Program/Utils.v b/theories/Program/Utils.v
index e39128cb..65fe8780 100644
--- a/theories/Program/Utils.v
+++ b/theories/Program/Utils.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(** Various syntaxic shortands that are useful with [Program]. *)
+(** Various syntactic shorthands that are useful with [Program]. *)
Require Export Coq.Program.Tactics.
diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v
index e848e4df..011328ec 100644
--- a/theories/Reals/Alembert.v
+++ b/theories/Reals/Alembert.v
@@ -572,6 +572,7 @@ Lemma Alembert_C6 :
(forall n:nat, An n <> 0) ->
Un_cv (fun n:nat => Rabs (An (S n) / An n)) k ->
Rabs x < / k -> { l:R | Pser An x l }.
+Proof.
intros.
cut { l:R | Un_cv (fun N:nat => sum_f_R0 (fun i:nat => An i * x ^ i) N) l }.
intro X.
diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v
index f5b34de9..6d30319c 100644
--- a/theories/Reals/Cos_rel.v
+++ b/theories/Reals/Cos_rel.v
@@ -10,7 +10,7 @@ Require Import Rbase.
Require Import Rfunctions.
Require Import SeqSeries.
Require Import Rtrigo_def.
-Require Import Omega.
+Require Import OmegaTactic.
Local Open Scope R_scope.
Definition A1 (x:R) (N:nat) : R :=
@@ -50,6 +50,7 @@ Theorem cos_plus_form :
forall (x y:R) (n:nat),
(0 < n)%nat ->
A1 x (S n) * A1 y (S n) - B1 x n * B1 y n + Reste x y n = C1 x y (S n).
+Proof.
intros.
unfold A1, B1.
rewrite
@@ -251,12 +252,14 @@ apply lt_O_Sn.
Qed.
Lemma pow_sqr : forall (x:R) (i:nat), x ^ (2 * i) = (x * x) ^ i.
+Proof.
intros.
assert (H := pow_Rsqr x i).
unfold Rsqr in H; exact H.
Qed.
Lemma A1_cvg : forall x:R, Un_cv (A1 x) (cos x).
+Proof.
intro.
unfold cos; destruct (exist_cos (Rsqr x)) as (x0,p).
unfold cos_in, cos_n, infinite_sum, R_dist in p.
@@ -276,6 +279,7 @@ apply pow_sqr.
Qed.
Lemma C1_cvg : forall x y:R, Un_cv (C1 x y) (cos (x + y)).
+Proof.
intros.
unfold cos.
destruct (exist_cos (Rsqr (x + y))) as (x0,p).
@@ -298,6 +302,7 @@ apply pow_sqr.
Qed.
Lemma B1_cvg : forall x:R, Un_cv (B1 x) (sin x).
+Proof.
intro.
case (Req_dec x 0); intro.
rewrite H.
diff --git a/theories/Reals/PSeries_reg.v b/theories/Reals/PSeries_reg.v
index 30a26f77..94b881cc 100644
--- a/theories/Reals/PSeries_reg.v
+++ b/theories/Reals/PSeries_reg.v
@@ -24,6 +24,7 @@ Definition Boule (x:R) (r:posreal) (y:R) : Prop := Rabs (y - x) < r.
Lemma Boule_convex : forall c d x y z,
Boule c d x -> Boule c d y -> x <= z <= y -> Boule c d z.
+Proof.
intros c d x y z bx b_y intz.
unfold Boule in bx, b_y; apply Rabs_def2 in bx;
apply Rabs_def2 in b_y; apply Rabs_def1;
@@ -33,6 +34,7 @@ Qed.
Definition boule_of_interval x y (h : x < y) :
{c :R & {r : posreal | c - r = x /\ c + r = y}}.
+Proof.
exists ((x + y)/2).
assert (radius : 0 < (y - x)/2).
unfold Rdiv; apply Rmult_lt_0_compat.
@@ -71,6 +73,7 @@ Qed.
Lemma Ball_in_inter : forall c1 c2 r1 r2 x,
Boule c1 r1 x -> Boule c2 r2 x ->
{r3 : posreal | forall y, Boule x r3 y -> Boule c1 r1 y /\ Boule c2 r2 y}.
+Proof.
intros c1 c2 [r1 r1p] [r2 r2p] x; unfold Boule; simpl; intros in1 in2.
assert (Rmax (c1 - r1)(c2 - r2) < x).
apply Rmax_lub_lt;[revert in1 | revert in2]; intros h;
@@ -366,6 +369,7 @@ Qed.
(* Uniform convergence implies pointwise simple convergence *)
Lemma CVU_cv : forall f g c d, CVU f g c d ->
forall x, Boule c d x -> Un_cv (fun n => f n x) (g x).
+Proof.
intros f g c d cvu x bx eps ep; destruct (cvu eps ep) as [N Pn].
exists N; intros n nN; rewrite R_dist_sym; apply Pn; assumption.
Qed.
@@ -374,6 +378,7 @@ Qed.
Lemma CVU_ext_lim :
forall f g1 g2 c d, CVU f g1 c d -> (forall x, Boule c d x -> g1 x = g2 x) ->
CVU f g2 c d.
+Proof.
intros f g1 g2 c d cvu q eps ep; destruct (cvu _ ep) as [N Pn].
exists N; intros; rewrite <- q; auto.
Qed.
@@ -388,6 +393,7 @@ Lemma CVU_derivable :
(forall x, Boule c d x -> Un_cv (fun n => f n x) (g x)) ->
(forall n x, Boule c d x -> derivable_pt_lim (f n) x (f' n x)) ->
forall x, Boule c d x -> derivable_pt_lim g x (g' x).
+Proof.
intros f f' g g' c d cvu cvp dff' x bx.
set (rho_ :=
fun n y =>
diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v
index 68718db0..cc45139d 100644
--- a/theories/Reals/Ratan.v
+++ b/theories/Reals/Ratan.v
@@ -450,6 +450,7 @@ fourier.
Qed.
Definition frame_tan y : {x | 0 < x < PI/2 /\ Rabs y < tan x}.
+Proof.
destruct (total_order_T (Rabs y) 1) as [Hs|Hgt].
assert (yle1 : Rabs y <= 1) by (destruct Hs; fourier).
clear Hs; exists 1; split;[split; [exact Rlt_0_1 | exact PI2_1] | ].
@@ -567,10 +568,12 @@ Lemma pos_opp_lt : forall x, 0 < x -> -x < x.
Proof. intros; fourier. Qed.
Lemma tech_opp_tan : forall x y, -tan x < y -> tan (-x) < y.
+Proof.
intros; rewrite tan_neg; assumption.
Qed.
Definition pre_atan (y : R) : {x : R | -PI/2 < x < PI/2 /\ tan x = y}.
+Proof.
destruct (frame_tan y) as [ub [[ub0 ubpi2] Ptan_ub]].
set (pr := (conj (tech_opp_tan _ _ (proj2 (Rabs_def2 _ _ Ptan_ub)))
(proj1 (Rabs_def2 _ _ Ptan_ub)))).
@@ -649,6 +652,7 @@ exact df_neq.
Qed.
Lemma atan_increasing : forall x y, x < y -> atan x < atan y.
+Proof.
intros x y d.
assert (t1 := atan_bound x).
assert (t2 := atan_bound y).
@@ -663,6 +667,7 @@ solve[rewrite yx; apply Rle_refl].
Qed.
Lemma atan_0 : atan 0 = 0.
+Proof.
apply tan_is_inj; try (apply atan_bound).
assert (t := PI_RGT_0); rewrite Ropp_div; split; fourier.
rewrite atan_right_inv, tan_0.
@@ -670,6 +675,7 @@ reflexivity.
Qed.
Lemma atan_1 : atan 1 = PI/4.
+Proof.
assert (ut := PI_RGT_0).
assert (-PI/2 < PI/4 < PI/2) by (rewrite Ropp_div; split; fourier).
assert (t := atan_bound 1).
@@ -865,6 +871,7 @@ Qed.
Definition ps_atan_exists_01 (x : R) (Hx:0 <= x <= 1) :
{l : R | Un_cv (fun N : nat => sum_f_R0 (tg_alt (Ratan_seq x)) N) l}.
+Proof.
exact (alternated_series (Ratan_seq x)
(Ratan_seq_decreasing _ Hx) (Ratan_seq_converging _ Hx)).
Defined.
@@ -888,6 +895,7 @@ Qed.
Definition ps_atan_exists_1 (x : R) (Hx : -1 <= x <= 1) :
{l : R | Un_cv (fun N : nat => sum_f_R0 (tg_alt (Ratan_seq x)) N) l}.
+Proof.
destruct (Rle_lt_dec 0 x).
assert (pr : 0 <= x <= 1) by tauto.
exact (ps_atan_exists_01 x pr).
@@ -902,6 +910,7 @@ solve[intros; exists 0%nat; intros; rewrite R_dist_eq; auto].
Qed.
Definition in_int (x : R) : {-1 <= x <= 1}+{~ -1 <= x <= 1}.
+Proof.
destruct (Rle_lt_dec x 1).
destruct (Rle_lt_dec (-1) x).
left;split; auto.
@@ -1563,6 +1572,7 @@ Qed.
Theorem Alt_PI_eq : Alt_PI = PI.
+Proof.
apply Rmult_eq_reg_r with (/4); fold (Alt_PI/4); fold (PI/4);
[ | apply Rgt_not_eq; fourier].
assert (0 < PI/6) by (apply PI6_RGT_0).
diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v
index 11d94c11..8e2b2d08 100644
--- a/theories/Structures/EqualitiesFacts.v
+++ b/theories/Structures/EqualitiesFacts.v
@@ -8,132 +8,172 @@
Require Import Equalities Bool SetoidList RelationPairs.
-(** * Keys and datas used in FMap *)
+Set Implicit Arguments.
-Module KeyDecidableType(Import D:DecidableType).
+(** * Keys and datas used in MMap *)
- Section Elt.
- Variable elt : Type.
- Notation key:=t.
+Module KeyDecidableType(D:DecidableType).
- Local Open Scope signature_scope.
+ Local Open Scope signature_scope.
+ Local Notation key := D.t.
- Definition eqk : relation (key*elt) := eq @@1.
- Definition eqke : relation (key*elt) := eq * Logic.eq.
- Hint Unfold eqk eqke.
+ Definition eqk {elt} : relation (key*elt) := D.eq @@1.
+ Definition eqke {elt} : relation (key*elt) := D.eq * Logic.eq.
- (* eqke is stricter than eqk *)
+ Hint Unfold eqk eqke.
- Global Instance eqke_eqk : subrelation eqke eqk.
- Proof. firstorder. Qed.
+ (** eqk, eqke are equalities *)
- (* eqk, eqke are equalities, ltk is a strict order *)
+ Instance eqk_equiv {elt} : Equivalence (@eqk elt) := _.
- Global Instance eqk_equiv : Equivalence eqk := _.
+ Instance eqke_equiv {elt} : Equivalence (@eqke elt) := _.
- Global Instance eqke_equiv : Equivalence eqke := _.
+ (** eqke is stricter than eqk *)
- (* Additionnal facts *)
+ Instance eqke_eqk {elt} : subrelation (@eqke elt) (@eqk elt).
+ Proof. firstorder. Qed.
- Lemma InA_eqke_eqk :
- forall x m, InA eqke x m -> InA eqk x m.
- Proof.
- unfold eqke, RelProd; induction 1; firstorder.
- Qed.
- Hint Resolve InA_eqke_eqk.
+ (** Alternative definitions of eqke and eqk *)
- Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m.
- Proof.
- intros. rewrite <- H; auto.
- Qed.
+ Lemma eqke_def {elt} k k' (e e':elt) :
+ eqke (k,e) (k',e') = (D.eq k k' /\ e = e').
+ Proof. reflexivity. Defined.
- Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
- Definition In k m := exists e:elt, MapsTo k e m.
+ Lemma eqke_def' {elt} (p q:key*elt) :
+ eqke p q = (D.eq (fst p) (fst q) /\ snd p = snd q).
+ Proof. reflexivity. Defined.
- Hint Unfold MapsTo In.
+ Lemma eqke_1 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> D.eq k k'.
+ Proof. now destruct 1. Qed.
- (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)
+ Lemma eqke_2 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> e=e'.
+ Proof. now destruct 1. Qed.
- Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
- Proof.
- firstorder.
- exists x; auto.
- induction H.
- destruct y; compute in H.
- exists e; left; auto.
- destruct IHInA as [e H0].
- exists e; auto.
- Qed.
-
- Lemma In_alt2 : forall k l, In k l <-> Exists (fun p => eq k (fst p)) l.
- Proof.
+ Lemma eqk_def {elt} k k' (e e':elt) : eqk (k,e) (k',e') = D.eq k k'.
+ Proof. reflexivity. Defined.
+
+ Lemma eqk_def' {elt} (p q:key*elt) : eqk p q = D.eq (fst p) (fst q).
+ Proof. reflexivity. Qed.
+
+ Lemma eqk_1 {elt} k k' (e e':elt) : eqk (k,e) (k',e') -> D.eq k k'.
+ Proof. trivial. Qed.
+
+ Hint Resolve eqke_1 eqke_2 eqk_1.
+
+ (* Additionnal facts *)
+
+ Lemma InA_eqke_eqk {elt} p (m:list (key*elt)) :
+ InA eqke p m -> InA eqk p m.
+ Proof.
+ induction 1; firstorder.
+ Qed.
+ Hint Resolve InA_eqke_eqk.
+
+ Lemma InA_eqk_eqke {elt} p (m:list (key*elt)) :
+ InA eqk p m -> exists q, eqk p q /\ InA eqke q m.
+ Proof.
+ induction 1; firstorder.
+ Qed.
+
+ Lemma InA_eqk {elt} p q (m:list (key*elt)) :
+ eqk p q -> InA eqk p m -> InA eqk q m.
+ Proof.
+ now intros <-.
+ Qed.
+
+ Definition MapsTo {elt} (k:key)(e:elt):= InA eqke (k,e).
+ Definition In {elt} k m := exists e:elt, MapsTo k e m.
+
+ Hint Unfold MapsTo In.
+
+ (* Alternative formulations for [In k l] *)
+
+ Lemma In_alt {elt} k (l:list (key*elt)) :
+ In k l <-> exists e, InA eqk (k,e) l.
+ Proof.
+ unfold In, MapsTo.
+ split; intros (e,H).
+ - exists e; auto.
+ - apply InA_eqk_eqke in H. destruct H as ((k',e'),(E,H)).
+ compute in E. exists e'. now rewrite E.
+ Qed.
+
+ Lemma In_alt' {elt} (l:list (key*elt)) k e :
+ In k l <-> InA eqk (k,e) l.
+ Proof.
+ rewrite In_alt. firstorder. eapply InA_eqk; eauto. now compute.
+ Qed.
+
+ Lemma In_alt2 {elt} k (l:list (key*elt)) :
+ In k l <-> Exists (fun p => D.eq k (fst p)) l.
+ Proof.
unfold In, MapsTo.
setoid_rewrite Exists_exists; setoid_rewrite InA_alt.
firstorder.
exists (snd x), x; auto.
- Qed.
-
- Lemma In_nil : forall k, In k nil <-> False.
- Proof.
- intros; rewrite In_alt2; apply Exists_nil.
- Qed.
-
- Lemma In_cons : forall k p l,
- In k (p::l) <-> eq k (fst p) \/ In k l.
- Proof.
- intros; rewrite !In_alt2, Exists_cons; intuition.
- Qed.
-
- Global Instance MapsTo_compat :
- Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo.
- Proof.
+ Qed.
+
+ Lemma In_nil {elt} k : In k (@nil (key*elt)) <-> False.
+ Proof.
+ rewrite In_alt2; apply Exists_nil.
+ Qed.
+
+ Lemma In_cons {elt} k p (l:list (key*elt)) :
+ In k (p::l) <-> D.eq k (fst p) \/ In k l.
+ Proof.
+ rewrite !In_alt2, Exists_cons; intuition.
+ Qed.
+
+ Instance MapsTo_compat {elt} :
+ Proper (D.eq==>Logic.eq==>equivlistA eqke==>iff) (@MapsTo elt).
+ Proof.
intros x x' Hx e e' He l l' Hl. unfold MapsTo.
rewrite Hx, He, Hl; intuition.
- Qed.
+ Qed.
- Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In.
- Proof.
+ Instance In_compat {elt} : Proper (D.eq==>equivlistA eqk==>iff) (@In elt).
+ Proof.
intros x x' Hx l l' Hl. rewrite !In_alt.
setoid_rewrite Hl. setoid_rewrite Hx. intuition.
- Qed.
-
- Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
- Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed.
+ Qed.
- Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
- Proof. intros l x y EQ. rewrite <- EQ; auto. Qed.
+ Lemma MapsTo_eq {elt} (l:list (key*elt)) x y e :
+ D.eq x y -> MapsTo x e l -> MapsTo y e l.
+ Proof. now intros <-. Qed.
- Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
- Proof.
- intros; invlist In; invlist MapsTo. compute in * |- ; intuition.
- right; exists x; auto.
- Qed.
+ Lemma In_eq {elt} (l:list (key*elt)) x y :
+ D.eq x y -> In x l -> In y l.
+ Proof. now intros <-. Qed.
- Lemma In_inv_2 : forall k k' e e' l,
- InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
- Proof.
- intros; invlist InA; intuition.
- Qed.
+ Lemma In_inv {elt} k k' e (l:list (key*elt)) :
+ In k ((k',e) :: l) -> D.eq k k' \/ In k l.
+ Proof.
+ intros (e',H). red in H. rewrite InA_cons, eqke_def in H.
+ intuition. right. now exists e'.
+ Qed.
- Lemma In_inv_3 : forall x x' l,
- InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
- Proof.
- intros; invlist InA; compute in * |- ; intuition.
- Qed.
+ Lemma In_inv_2 {elt} k k' e e' (l:list (key*elt)) :
+ InA eqk (k, e) ((k', e') :: l) -> ~ D.eq k k' -> InA eqk (k, e) l.
+ Proof.
+ rewrite InA_cons, eqk_def. intuition.
+ Qed.
- End Elt.
+ Lemma In_inv_3 {elt} x x' (l:list (key*elt)) :
+ InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
+ Proof.
+ rewrite InA_cons. destruct 1 as [H|H]; trivial. destruct 1.
+ eauto with *.
+ Qed.
- Hint Unfold eqk eqke.
Hint Extern 2 (eqke ?a ?b) => split.
Hint Resolve InA_eqke_eqk.
- Hint Unfold MapsTo In.
Hint Resolve In_inv_2 In_inv_3.
End KeyDecidableType.
-(** * PairDecidableType
-
+(** * PairDecidableType
+
From two decidable types, we can build a new DecidableType
over their cartesian product. *)
diff --git a/theories/Structures/OrdersEx.v b/theories/Structures/OrdersEx.v
index acc7c767..b484257b 100644
--- a/theories/Structures/OrdersEx.v
+++ b/theories/Structures/OrdersEx.v
@@ -84,3 +84,70 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType.
End PairOrderedType.
+(** Even if [positive] can be seen as an ordered type with respect to the
+ usual order (see above), we can also use a lexicographic order over bits
+ (lower bits are considered first). This is more natural when using
+ [positive] as indexes for sets or maps (see MSetPositive and MMapPositive. *)
+
+Local Open Scope positive.
+
+Module PositiveOrderedTypeBits <: UsualOrderedType.
+ Definition t:=positive.
+ Include HasUsualEq <+ UsualIsEq.
+ Definition eqb := Pos.eqb.
+ Definition eqb_eq := Pos.eqb_eq.
+ Include HasEqBool2Dec.
+
+ Fixpoint bits_lt (p q:positive) : Prop :=
+ match p, q with
+ | xH, xI _ => True
+ | xH, _ => False
+ | xO p, xO q => bits_lt p q
+ | xO _, _ => True
+ | xI p, xI q => bits_lt p q
+ | xI _, _ => False
+ end.
+
+ Definition lt:=bits_lt.
+
+ Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x.
+ Proof.
+ induction x; simpl; auto.
+ Qed.
+
+ Lemma bits_lt_trans :
+ forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z.
+ Proof.
+ induction x; destruct y,z; simpl; eauto; intuition.
+ Qed.
+
+ Instance lt_compat : Proper (eq==>eq==>iff) lt.
+ Proof.
+ intros x x' Hx y y' Hy. rewrite Hx, Hy; intuition.
+ Qed.
+
+ Instance lt_strorder : StrictOrder lt.
+ Proof.
+ split; [ exact bits_lt_antirefl | exact bits_lt_trans ].
+ Qed.
+
+ Fixpoint compare x y :=
+ match x, y with
+ | x~1, y~1 => compare x y
+ | x~1, _ => Gt
+ | x~0, y~0 => compare x y
+ | x~0, _ => Lt
+ | 1, y~1 => Lt
+ | 1, 1 => Eq
+ | 1, y~0 => Gt
+ end.
+
+ Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y).
+ Proof.
+ unfold eq, lt.
+ induction x; destruct y; try constructor; simpl; auto.
+ destruct (IHx y); subst; auto.
+ destruct (IHx y); subst; auto.
+ Qed.
+
+End PositiveOrderedTypeBits.
diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v
index 059992f5..4d49ac84 100644
--- a/theories/Structures/OrdersLists.v
+++ b/theories/Structures/OrdersLists.v
@@ -6,51 +6,47 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-Require Export RelationPairs SetoidList Orders.
+Require Export RelationPairs SetoidList Orders EqualitiesFacts.
Set Implicit Arguments.
Unset Strict Implicit.
(** * Specialization of results about lists modulo. *)
-Module OrderedTypeLists (Import O:OrderedType).
+Module OrderedTypeLists (O:OrderedType).
-Section ForNotations.
-
-Notation In:=(InA eq).
-Notation Inf:=(lelistA lt).
-Notation Sort:=(sort lt).
-Notation NoDup:=(NoDupA eq).
+Local Notation In:=(InA O.eq).
+Local Notation Inf:=(lelistA O.lt).
+Local Notation Sort:=(sort O.lt).
+Local Notation NoDup:=(NoDupA O.eq).
Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
Proof. intros. rewrite <- H; auto. Qed.
Lemma ListIn_In : forall l x, List.In x l -> In x l.
-Proof. exact (In_InA eq_equiv). Qed.
+Proof. exact (In_InA O.eq_equiv). Qed.
-Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l.
-Proof. exact (InfA_ltA lt_strorder). Qed.
+Lemma Inf_lt : forall l x y, O.lt x y -> Inf y l -> Inf x l.
+Proof. exact (InfA_ltA O.lt_strorder). Qed.
-Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l.
-Proof. exact (InfA_eqA eq_equiv lt_compat). Qed.
+Lemma Inf_eq : forall l x y, O.eq x y -> Inf y l -> Inf x l.
+Proof. exact (InfA_eqA O.eq_equiv O.lt_compat). Qed.
-Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x.
-Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed.
+Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> O.lt a x.
+Proof. exact (SortA_InfA_InA O.eq_equiv O.lt_strorder O.lt_compat). Qed.
-Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l.
-Proof. exact (@In_InfA t lt). Qed.
+Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> O.lt x y) -> Inf x l.
+Proof. exact (@In_InfA O.t O.lt). Qed.
-Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l.
-Proof. exact (InA_InfA eq_equiv (ltA:=lt)). Qed.
+Lemma In_Inf : forall l x, (forall y, In y l -> O.lt x y) -> Inf x l.
+Proof. exact (InA_InfA O.eq_equiv (ltA:=O.lt)). Qed.
Lemma Inf_alt :
- forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)).
-Proof. exact (InfA_alt eq_equiv lt_strorder lt_compat). Qed.
+ forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> O.lt x y)).
+Proof. exact (InfA_alt O.eq_equiv O.lt_strorder O.lt_compat). Qed.
Lemma Sort_NoDup : forall l, Sort l -> NoDup l.
-Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat) . Qed.
-
-End ForNotations.
+Proof. exact (SortA_NoDupA O.eq_equiv O.lt_strorder O.lt_compat) . Qed.
Hint Resolve ListIn_In Sort_NoDup Inf_lt.
Hint Immediate In_eq Inf_lt.
@@ -58,140 +54,66 @@ Hint Immediate In_eq Inf_lt.
End OrderedTypeLists.
+(** * Results about keys and data as manipulated in MMaps. *)
+Module KeyOrderedType(O:OrderedType).
+ Include KeyDecidableType(O). (* provides eqk, eqke *)
+ Local Notation key:=O.t.
+ Local Open Scope signature_scope.
-(** * Results about keys and data as manipulated in FMaps. *)
-
-
-Module KeyOrderedType(Import O:OrderedType).
- Module Import MO:=OrderedTypeLists(O).
-
- Section Elt.
- Variable elt : Type.
- Notation key:=t.
-
- Local Open Scope signature_scope.
-
- Definition eqk : relation (key*elt) := eq @@1.
- Definition eqke : relation (key*elt) := eq * Logic.eq.
- Definition ltk : relation (key*elt) := lt @@1.
-
- Hint Unfold eqk eqke ltk.
+ Definition ltk {elt} : relation (key*elt) := O.lt @@1.
- (* eqke is stricter than eqk *)
+ Hint Unfold ltk.
- Global Instance eqke_eqk : subrelation eqke eqk.
- Proof. firstorder. Qed.
+ (* ltk is a strict order *)
- (* eqk, eqke are equalities, ltk is a strict order *)
+ Instance ltk_strorder {elt} : StrictOrder (@ltk elt) := _.
- Global Instance eqk_equiv : Equivalence eqk := _.
+ Instance ltk_compat {elt} : Proper (eqk==>eqk==>iff) (@ltk elt).
+ Proof. unfold eqk, ltk; auto with *. Qed.
- Global Instance eqke_equiv : Equivalence eqke := _.
+ Instance ltk_compat' {elt} : Proper (eqke==>eqke==>iff) (@ltk elt).
+ Proof. eapply subrelation_proper; eauto with *. Qed.
- Global Instance ltk_strorder : StrictOrder ltk := _.
+ (* Additionnal facts *)
- Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk.
- Proof. unfold eqk, ltk; auto with *. Qed.
+ Instance pair_compat {elt} : Proper (O.eq==>Logic.eq==>eqke) (@pair key elt).
+ Proof. apply pair_compat. Qed.
- (* Additionnal facts *)
-
- Global Instance pair_compat : Proper (eq==>Logic.eq==>eqke) (@pair key elt).
- Proof. apply pair_compat. Qed.
+ Section Elt.
+ Variable elt : Type.
+ Implicit Type p q : key*elt.
+ Implicit Type l m : list (key*elt).
- Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'.
+ Lemma ltk_not_eqk p q : ltk p q -> ~ eqk p q.
Proof.
- intros e e' LT EQ; rewrite EQ in LT.
+ intros LT EQ; rewrite EQ in LT.
elim (StrictOrder_Irreflexive _ LT).
Qed.
- Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'.
+ Lemma ltk_not_eqke p q : ltk p q -> ~eqke p q.
Proof.
- intros e e' LT EQ; rewrite EQ in LT.
+ intros LT EQ; rewrite EQ in LT.
elim (StrictOrder_Irreflexive _ LT).
Qed.
- Lemma InA_eqke_eqk :
- forall x m, InA eqke x m -> InA eqk x m.
- Proof.
- unfold eqke, RelProd; induction 1; firstorder.
- Qed.
- Hint Resolve InA_eqke_eqk.
-
- Definition MapsTo (k:key)(e:elt):= InA eqke (k,e).
- Definition In k m := exists e:elt, MapsTo k e m.
Notation Sort := (sort ltk).
Notation Inf := (lelistA ltk).
- Hint Unfold MapsTo In.
-
- (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *)
-
- Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l.
- Proof.
- firstorder.
- exists x; auto.
- induction H.
- destruct y; compute in H.
- exists e; left; auto.
- destruct IHInA as [e H0].
- exists e; auto.
- Qed.
+ Lemma Inf_eq l x x' : eqk x x' -> Inf x' l -> Inf x l.
+ Proof. now intros <-. Qed.
- Lemma In_alt2 : forall k l, In k l <-> Exists (fun p => eq k (fst p)) l.
- Proof.
- unfold In, MapsTo.
- setoid_rewrite Exists_exists; setoid_rewrite InA_alt.
- firstorder.
- exists (snd x), x; auto.
- Qed.
-
- Lemma In_nil : forall k, In k nil <-> False.
- Proof.
- intros; rewrite In_alt2; apply Exists_nil.
- Qed.
-
- Lemma In_cons : forall k p l,
- In k (p::l) <-> eq k (fst p) \/ In k l.
- Proof.
- intros; rewrite !In_alt2, Exists_cons; intuition.
- Qed.
-
- Global Instance MapsTo_compat :
- Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo.
- Proof.
- intros x x' Hx e e' He l l' Hl. unfold MapsTo.
- rewrite Hx, He, Hl; intuition.
- Qed.
-
- Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In.
- Proof.
- intros x x' Hx l l' Hl. rewrite !In_alt.
- setoid_rewrite Hl. setoid_rewrite Hx. intuition.
- Qed.
-
- Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l.
- Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed.
-
- Lemma In_eq : forall l x y, eq x y -> In x l -> In y l.
- Proof. intros l x y EQ. rewrite <- EQ; auto. Qed.
-
- Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l.
- Proof. intros l x x' H. rewrite H; auto. Qed.
-
- Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l.
+ Lemma Inf_lt l x x' : ltk x x' -> Inf x' l -> Inf x l.
Proof. apply InfA_ltA; auto with *. Qed.
Hint Immediate Inf_eq.
Hint Resolve Inf_lt.
- Lemma Sort_Inf_In :
- forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p.
+ Lemma Sort_Inf_In l p q : Sort l -> Inf q l -> InA eqk p l -> ltk q p.
Proof. apply SortA_InfA_InA; auto with *. Qed.
- Lemma Sort_Inf_NotIn :
- forall l k e, Sort l -> Inf (k,e) l -> ~In k l.
+ Lemma Sort_Inf_NotIn l k e : Sort l -> Inf (k,e) l -> ~In k l.
Proof.
intros; red; intros.
destruct H1 as [e' H2].
@@ -200,57 +122,34 @@ Module KeyOrderedType(Import O:OrderedType).
repeat red; reflexivity.
Qed.
- Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l.
+ Lemma Sort_NoDupA l : Sort l -> NoDupA eqk l.
Proof. apply SortA_NoDupA; auto with *. Qed.
- Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'.
+ Lemma Sort_In_cons_1 l p q : Sort (p::l) -> InA eqk q l -> ltk p q.
Proof.
intros; invlist sort; eapply Sort_Inf_In; eauto.
Qed.
- Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) ->
- ltk e e' \/ eqk e e'.
+ Lemma Sort_In_cons_2 l p q : Sort (p::l) -> InA eqk q (p::l) ->
+ ltk p q \/ eqk p q.
Proof.
intros; invlist InA; auto with relations.
left; apply Sort_In_cons_1 with l; auto with relations.
Qed.
- Lemma Sort_In_cons_3 :
- forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k.
+ Lemma Sort_In_cons_3 x l k e :
+ Sort ((k,e)::l) -> In x l -> ~O.eq x k.
Proof.
intros; invlist sort; red; intros.
eapply Sort_Inf_NotIn; eauto using In_eq.
Qed.
- Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l.
- Proof.
- intros; invlist In; invlist MapsTo. compute in * |- ; intuition.
- right; exists x; auto.
- Qed.
-
- Lemma In_inv_2 : forall k k' e e' l,
- InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l.
- Proof.
- intros; invlist InA; intuition.
- Qed.
-
- Lemma In_inv_3 : forall x x' l,
- InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
- Proof.
- intros; invlist InA; compute in * |- ; intuition.
- Qed.
-
End Elt.
- Hint Unfold eqk eqke ltk.
- Hint Extern 2 (eqke ?a ?b) => split.
Hint Resolve ltk_not_eqk ltk_not_eqke.
- Hint Resolve InA_eqke_eqk.
- Hint Unfold MapsTo In.
Hint Immediate Inf_eq.
Hint Resolve Inf_lt.
Hint Resolve Sort_Inf_NotIn.
- Hint Resolve In_inv_2 In_inv_3.
End KeyOrderedType.
diff --git a/theories/ZArith/Int.v b/theories/ZArith/Int.v
index 99ecd150..d210792f 100644
--- a/theories/ZArith/Int.v
+++ b/theories/ZArith/Int.v
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(***********************************************************************)
-(** * An light axiomatization of integers (used in FSetAVL). *)
+(** * An light axiomatization of integers (used in MSetAVL). *)
(** We define a signature for an integer datatype based on [Z].
The goal is to allow a switch after extraction to ocaml's
@@ -14,11 +14,11 @@
(typically : when mesuring the height of an AVL tree).
*)
-Require Import ZArith.
+Require Import BinInt.
Delimit Scope Int_scope with I.
Local Open Scope Int_scope.
-(** * a specification of integers *)
+(** * A specification of integers *)
Module Type Int.
@@ -31,19 +31,19 @@ Module Type Int.
Parameter _1 : t.
Parameter _2 : t.
Parameter _3 : t.
- Parameter plus : t -> t -> t.
+ Parameter add : t -> t -> t.
Parameter opp : t -> t.
- Parameter minus : t -> t -> t.
- Parameter mult : t -> t -> t.
+ Parameter sub : t -> t -> t.
+ Parameter mul : t -> t -> t.
Parameter max : t -> t -> t.
Notation "0" := _0 : Int_scope.
Notation "1" := _1 : Int_scope.
Notation "2" := _2 : Int_scope.
Notation "3" := _3 : Int_scope.
- Infix "+" := plus : Int_scope.
- Infix "-" := minus : Int_scope.
- Infix "*" := mult : Int_scope.
+ Infix "+" := add : Int_scope.
+ Infix "-" := sub : Int_scope.
+ Infix "*" := mul : Int_scope.
Notation "- x" := (opp x) : Int_scope.
(** For logical relations, we can rely on their counterparts in Z,
@@ -61,7 +61,17 @@ Module Type Int.
Notation "x < y < z" := (x < y /\ y < z) : Int_scope.
Notation "x < y <= z" := (x < y /\ y <= z) : Int_scope.
- (** Some decidability fonctions (informative). *)
+ (** Informative comparisons. *)
+
+ Axiom eqb : t -> t -> bool.
+ Axiom ltb : t -> t -> bool.
+ Axiom leb : t -> t -> bool.
+
+ Infix "=?" := eqb.
+ Infix "<?" := ltb.
+ Infix "<=?" := leb.
+
+ (** For compatibility, some decidability fonctions (informative). *)
Axiom gt_le_dec : forall x y : t, {x > y} + {x <= y}.
Axiom ge_lt_dec : forall x y : t, {x >= y} + {x < y}.
@@ -83,11 +93,14 @@ Module Type Int.
Axiom i2z_1 : i2z _1 = 1%Z.
Axiom i2z_2 : i2z _2 = 2%Z.
Axiom i2z_3 : i2z _3 = 3%Z.
- Axiom i2z_plus : forall n p, i2z (n + p) = (i2z n + i2z p)%Z.
+ Axiom i2z_add : forall n p, i2z (n + p) = (i2z n + i2z p)%Z.
Axiom i2z_opp : forall n, i2z (-n) = (-i2z n)%Z.
- Axiom i2z_minus : forall n p, i2z (n - p) = (i2z n - i2z p)%Z.
- Axiom i2z_mult : forall n p, i2z (n * p) = (i2z n * i2z p)%Z.
+ Axiom i2z_sub : forall n p, i2z (n - p) = (i2z n - i2z p)%Z.
+ Axiom i2z_mul : forall n p, i2z (n * p) = (i2z n * i2z p)%Z.
Axiom i2z_max : forall n p, i2z (max n p) = Z.max (i2z n) (i2z p).
+ Axiom i2z_eqb : forall n p, eqb n p = Z.eqb (i2z n) (i2z p).
+ Axiom i2z_ltb : forall n p, ltb n p = Z.ltb (i2z n) (i2z p).
+ Axiom i2z_leb : forall n p, leb n p = Z.leb (i2z n) (i2z p).
End Int.
@@ -97,11 +110,42 @@ End Int.
Module MoreInt (Import I:Int).
Local Notation int := I.t.
+ Lemma eqb_eq n p : (n =? p) = true <-> n == p.
+ Proof.
+ now rewrite i2z_eqb, Z.eqb_eq.
+ Qed.
+
+ Lemma eqb_neq n p : (n =? p) = false <-> ~(n == p).
+ Proof.
+ rewrite <- eqb_eq. destruct (n =? p); intuition.
+ Qed.
+
+ Lemma ltb_lt n p : (n <? p) = true <-> n < p.
+ Proof.
+ now rewrite i2z_ltb, Z.ltb_lt.
+ Qed.
+
+ Lemma ltb_nlt n p : (n <? p) = false <-> ~(n < p).
+ Proof.
+ rewrite <- ltb_lt. destruct (n <? p); intuition.
+ Qed.
+
+ Lemma leb_le n p : (n <=? p) = true <-> n <= p.
+ Proof.
+ now rewrite i2z_leb, Z.leb_le.
+ Qed.
+
+ Lemma leb_nle n p : (n <=? p) = false <-> ~(n <= p).
+ Proof.
+ rewrite <- leb_le. destruct (n <=? p); intuition.
+ Qed.
+
(** A magic (but costly) tactic that goes from [int] back to the [Z]
friendly world ... *)
Hint Rewrite ->
- i2z_0 i2z_1 i2z_2 i2z_3 i2z_plus i2z_opp i2z_minus i2z_mult i2z_max : i2z.
+ i2z_0 i2z_1 i2z_2 i2z_3 i2z_add i2z_opp i2z_sub i2z_mul i2z_max
+ i2z_eqb i2z_ltb i2z_leb : i2z.
Ltac i2z := match goal with
| H : ?a = ?b |- _ =>
@@ -149,18 +193,18 @@ Module MoreInt (Import I:Int).
| EI1 : ExprI
| EI2 : ExprI
| EI3 : ExprI
- | EIplus : ExprI -> ExprI -> ExprI
+ | EIadd : ExprI -> ExprI -> ExprI
| EIopp : ExprI -> ExprI
- | EIminus : ExprI -> ExprI -> ExprI
- | EImult : ExprI -> ExprI -> ExprI
+ | EIsub : ExprI -> ExprI -> ExprI
+ | EImul : ExprI -> ExprI -> ExprI
| EImax : ExprI -> ExprI -> ExprI
| EIraw : int -> ExprI.
Inductive ExprZ : Set :=
- | EZplus : ExprZ -> ExprZ -> ExprZ
+ | EZadd : ExprZ -> ExprZ -> ExprZ
| EZopp : ExprZ -> ExprZ
- | EZminus : ExprZ -> ExprZ -> ExprZ
- | EZmult : ExprZ -> ExprZ -> ExprZ
+ | EZsub : ExprZ -> ExprZ -> ExprZ
+ | EZmul : ExprZ -> ExprZ -> ExprZ
| EZmax : ExprZ -> ExprZ -> ExprZ
| EZofI : ExprI -> ExprZ
| EZraw : Z -> ExprZ.
@@ -186,9 +230,9 @@ Module MoreInt (Import I:Int).
| 1 => constr:EI1
| 2 => constr:EI2
| 3 => constr:EI3
- | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIplus ex ey)
- | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIminus ex ey)
- | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImult ex ey)
+ | ?x + ?y => let ex := i2ei x with ey := i2ei y in constr:(EIadd ex ey)
+ | ?x - ?y => let ex := i2ei x with ey := i2ei y in constr:(EIsub ex ey)
+ | ?x * ?y => let ex := i2ei x with ey := i2ei y in constr:(EImul ex ey)
| max ?x ?y => let ex := i2ei x with ey := i2ei y in constr:(EImax ex ey)
| - ?x => let ex := i2ei x in constr:(EIopp ex)
| ?x => constr:(EIraw x)
@@ -198,9 +242,9 @@ Module MoreInt (Import I:Int).
with z2ez trm :=
match constr:trm with
- | (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZplus ex ey)
- | (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZminus ex ey)
- | (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmult ex ey)
+ | (?x + ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZadd ex ey)
+ | (?x - ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZsub ex ey)
+ | (?x * ?y)%Z => let ex := z2ez x with ey := z2ez y in constr:(EZmul ex ey)
| (Z.max ?x ?y) => let ex := z2ez x with ey := z2ez y in constr:(EZmax ex ey)
| (- ?x)%Z => let ex := z2ez x in constr:(EZopp ex)
| i2z ?x => let ex := i2ei x in constr:(EZofI ex)
@@ -232,9 +276,9 @@ Module MoreInt (Import I:Int).
| EI1 => 1
| EI2 => 2
| EI3 => 3
- | EIplus e1 e2 => (ei2i e1)+(ei2i e2)
- | EIminus e1 e2 => (ei2i e1)-(ei2i e2)
- | EImult e1 e2 => (ei2i e1)*(ei2i e2)
+ | EIadd e1 e2 => (ei2i e1)+(ei2i e2)
+ | EIsub e1 e2 => (ei2i e1)-(ei2i e2)
+ | EImul e1 e2 => (ei2i e1)*(ei2i e2)
| EImax e1 e2 => max (ei2i e1) (ei2i e2)
| EIopp e => -(ei2i e)
| EIraw i => i
@@ -244,9 +288,9 @@ Module MoreInt (Import I:Int).
Fixpoint ez2z (e:ExprZ) : Z :=
match e with
- | EZplus e1 e2 => ((ez2z e1)+(ez2z e2))%Z
- | EZminus e1 e2 => ((ez2z e1)-(ez2z e2))%Z
- | EZmult e1 e2 => ((ez2z e1)*(ez2z e2))%Z
+ | EZadd e1 e2 => ((ez2z e1)+(ez2z e2))%Z
+ | EZsub e1 e2 => ((ez2z e1)-(ez2z e2))%Z
+ | EZmul e1 e2 => ((ez2z e1)*(ez2z e2))%Z
| EZmax e1 e2 => Z.max (ez2z e1) (ez2z e2)
| EZopp e => (-(ez2z e))%Z
| EZofI e => i2z (ei2i e)
@@ -278,9 +322,9 @@ Module MoreInt (Import I:Int).
| EI1 => EZraw (1%Z)
| EI2 => EZraw (2%Z)
| EI3 => EZraw (3%Z)
- | EIplus e1 e2 => EZplus (norm_ei e1) (norm_ei e2)
- | EIminus e1 e2 => EZminus (norm_ei e1) (norm_ei e2)
- | EImult e1 e2 => EZmult (norm_ei e1) (norm_ei e2)
+ | EIadd e1 e2 => EZadd (norm_ei e1) (norm_ei e2)
+ | EIsub e1 e2 => EZsub (norm_ei e1) (norm_ei e2)
+ | EImul e1 e2 => EZmul (norm_ei e1) (norm_ei e2)
| EImax e1 e2 => EZmax (norm_ei e1) (norm_ei e2)
| EIopp e => EZopp (norm_ei e)
| EIraw i => EZofI (EIraw i)
@@ -290,9 +334,9 @@ Module MoreInt (Import I:Int).
Fixpoint norm_ez (e:ExprZ) : ExprZ :=
match e with
- | EZplus e1 e2 => EZplus (norm_ez e1) (norm_ez e2)
- | EZminus e1 e2 => EZminus (norm_ez e1) (norm_ez e2)
- | EZmult e1 e2 => EZmult (norm_ez e1) (norm_ez e2)
+ | EZadd e1 e2 => EZadd (norm_ez e1) (norm_ez e2)
+ | EZsub e1 e2 => EZsub (norm_ez e1) (norm_ez e2)
+ | EZmul e1 e2 => EZmul (norm_ez e1) (norm_ez e2)
| EZmax e1 e2 => EZmax (norm_ez e1) (norm_ez e2)
| EZopp e => EZopp (norm_ez e)
| EZofI e => norm_ei e
@@ -316,24 +360,22 @@ Module MoreInt (Import I:Int).
| EPraw p => EPraw p
end.
- Lemma norm_ei_correct : forall e:ExprI, ez2z (norm_ei e) = i2z (ei2i e).
+ Lemma norm_ei_correct (e:ExprI) : ez2z (norm_ei e) = i2z (ei2i e).
Proof.
- induction e; simpl; intros; i2z; auto; try congruence.
+ induction e; simpl; i2z; auto; try congruence.
Qed.
- Lemma norm_ez_correct : forall e:ExprZ, ez2z (norm_ez e) = ez2z e.
+ Lemma norm_ez_correct (e:ExprZ) : ez2z (norm_ez e) = ez2z e.
Proof.
- induction e; simpl; intros; i2z; auto; try congruence; apply norm_ei_correct.
+ induction e; simpl; i2z; auto; try congruence; apply norm_ei_correct.
Qed.
- Lemma norm_ep_correct :
- forall e:ExprP, ep2p (norm_ep e) <-> ep2p e.
+ Lemma norm_ep_correct (e:ExprP) : ep2p (norm_ep e) <-> ep2p e.
Proof.
- induction e; simpl; repeat (rewrite norm_ez_correct); intuition.
+ induction e; simpl; rewrite ?norm_ez_correct; intuition.
Qed.
- Lemma norm_ep_correct2 :
- forall e:ExprP, ep2p (norm_ep e) -> ep2p e.
+ Lemma norm_ep_correct2 (e:ExprP) : ep2p (norm_ep e) -> ep2p e.
Proof.
intros; destruct (norm_ep_correct e); auto.
Qed.
@@ -363,23 +405,50 @@ Module Z_as_Int <: Int.
Definition _1 := 1.
Definition _2 := 2.
Definition _3 := 3.
- Definition plus := Z.add.
+ Definition add := Z.add.
Definition opp := Z.opp.
- Definition minus := Z.sub.
- Definition mult := Z.mul.
+ Definition sub := Z.sub.
+ Definition mul := Z.mul.
Definition max := Z.max.
- Definition gt_le_dec := Z_gt_le_dec.
- Definition ge_lt_dec := Z_ge_lt_dec.
+ Definition eqb := Z.eqb.
+ Definition ltb := Z.ltb.
+ Definition leb := Z.leb.
+
Definition eq_dec := Z.eq_dec.
+ Definition gt_le_dec i j : {i > j} + { i <= j }.
+ Proof.
+ generalize (Z.ltb_spec j i).
+ destruct (j <? i); [left|right]; inversion H; trivial.
+ now apply Z.lt_gt.
+ Defined.
+ Definition ge_lt_dec i j : {i >= j} + { i < j }.
+ Proof.
+ generalize (Z.ltb_spec i j).
+ destruct (i <? j); [right|left]; inversion H; trivial.
+ now apply Z.le_ge.
+ Defined.
+
Definition i2z : t -> Z := fun n => n.
- Lemma i2z_eq : forall n p, i2z n=i2z p -> n = p. Proof. auto. Qed.
- Lemma i2z_0 : i2z _0 = 0. Proof. auto. Qed.
- Lemma i2z_1 : i2z _1 = 1. Proof. auto. Qed.
- Lemma i2z_2 : i2z _2 = 2. Proof. auto. Qed.
- Lemma i2z_3 : i2z _3 = 3. Proof. auto. Qed.
- Lemma i2z_plus n p : i2z (n + p) = i2z n + i2z p. Proof. auto. Qed.
- Lemma i2z_opp n : i2z (- n) = - i2z n. Proof. auto. Qed.
- Lemma i2z_minus n p : i2z (n - p) = i2z n - i2z p. Proof. auto. Qed.
- Lemma i2z_mult n p : i2z (n * p) = i2z n * i2z p. Proof. auto. Qed.
- Lemma i2z_max n p : i2z (max n p) = Z.max (i2z n) (i2z p). Proof. auto. Qed.
+ Lemma i2z_eq n p : i2z n = i2z p -> n = p. Proof. trivial. Qed.
+ Lemma i2z_0 : i2z _0 = 0. Proof. reflexivity. Qed.
+ Lemma i2z_1 : i2z _1 = 1. Proof. reflexivity. Qed.
+ Lemma i2z_2 : i2z _2 = 2. Proof. reflexivity. Qed.
+ Lemma i2z_3 : i2z _3 = 3. Proof. reflexivity. Qed.
+ Lemma i2z_add n p : i2z (n + p) = i2z n + i2z p.
+ Proof. reflexivity. Qed.
+ Lemma i2z_opp n : i2z (- n) = - i2z n.
+ Proof. reflexivity. Qed.
+ Lemma i2z_sub n p : i2z (n - p) = i2z n - i2z p.
+ Proof. reflexivity. Qed.
+ Lemma i2z_mul n p : i2z (n * p) = i2z n * i2z p.
+ Proof. reflexivity. Qed.
+ Lemma i2z_max n p : i2z (max n p) = Z.max (i2z n) (i2z p).
+ Proof. reflexivity. Qed.
+ Lemma i2z_eqb n p : eqb n p = Z.eqb (i2z n) (i2z p).
+ Proof. reflexivity. Qed.
+ Lemma i2z_leb n p : leb n p = Z.leb (i2z n) (i2z p).
+ Proof. reflexivity. Qed.
+ Lemma i2z_ltb n p : ltb n p = Z.ltb (i2z n) (i2z p).
+ Proof. reflexivity. Qed.
+
End Z_as_Int.
diff --git a/theories/theories.itarget b/theories/theories.itarget
index 3a87d8cf..4519070e 100644
--- a/theories/theories.itarget
+++ b/theories/theories.itarget
@@ -3,6 +3,7 @@ Bool/vo.otarget
Classes/vo.otarget
FSets/vo.otarget
MSets/vo.otarget
+MMaps/vo.otarget
Structures/vo.otarget
Init/vo.otarget
Lists/vo.otarget