From 0aa2544d04dbd4b6ee665b551ed165e4fb02d2fa Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Wed, 15 Jul 2015 10:36:12 +0200 Subject: Imported Upstream version 8.5~beta2+dfsg --- theories/Classes/CMorphisms.v | 24 +- theories/Init/Logic.v | 3 - theories/Init/Notations.v | 2 +- theories/Init/Prelude.v | 2 +- theories/Init/Tactics.v | 14 +- theories/Lists/List.v | 10 +- theories/Lists/SetoidList.v | 11 +- theories/Lists/SetoidPermutation.v | 74 +- theories/MMaps/MMapAVL.v | 2158 +++++++++++++++++++++++++++++ theories/MMaps/MMapFacts.v | 2434 +++++++++++++++++++++++++++++++++ theories/MMaps/MMapInterface.v | 292 ++++ theories/MMaps/MMapList.v | 1144 ++++++++++++++++ theories/MMaps/MMapPositive.v | 698 ++++++++++ theories/MMaps/MMapWeakList.v | 687 ++++++++++ theories/MMaps/MMaps.v | 16 + theories/MMaps/vo.itarget | 7 + theories/MSets/MSetAVL.v | 18 +- theories/MSets/MSetPositive.v | 81 +- theories/Program/Equality.v | 11 +- theories/Program/Utils.v | 2 +- theories/Reals/Alembert.v | 1 + theories/Reals/Cos_rel.v | 7 +- theories/Reals/PSeries_reg.v | 6 + theories/Reals/Ratan.v | 10 + theories/Structures/EqualitiesFacts.v | 216 +-- theories/Structures/OrdersEx.v | 67 + theories/Structures/OrdersLists.v | 211 +-- theories/ZArith/Int.v | 193 ++- theories/theories.itarget | 1 + 29 files changed, 7972 insertions(+), 428 deletions(-) create mode 100644 theories/MMaps/MMapAVL.v create mode 100644 theories/MMaps/MMapFacts.v create mode 100644 theories/MMaps/MMapInterface.v create mode 100644 theories/MMaps/MMapList.v create mode 100644 theories/MMaps/MMapPositive.v create mode 100644 theories/MMaps/MMapWeakList.v create mode 100644 theories/MMaps/MMaps.v create mode 100644 theories/MMaps/vo.itarget (limited to 'theories') 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 *) +(* 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) 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) 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 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 + 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 + 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 *) +(* (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 *) +(* 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 *) +(* + 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 *) +(* 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 *) +(* 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 *) +(* 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) 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) 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) 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 " 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 n < p. + Proof. + now rewrite i2z_ltb, Z.ltb_lt. + Qed. + + Lemma ltb_nlt n p : (n ~(n < p). + Proof. + rewrite <- ltb_lt. destruct (n 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 = j} + { i < j }. + Proof. + generalize (Z.ltb_spec i j). + destruct (i 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 -- cgit v1.2.3