diff options
| author |  Stephane Glondu <steph@glondu.net> | 2010-07-21 09:46:51 +0200 |
|---|---|---|
| committer | Stephane Glondu <steph@glondu.net> | 2010-07-21 09:46:51 +0200 |
| commit | 5b7eafd0f00a16d78f99a27f5c7d5a0de77dc7e6 (patch) | |
| tree | 631ad791a7685edafeb1fb2e8faeedc8379318ae /theories/FSets | |
| parent | da178a880e3ace820b41d38b191d3785b82991f5 (diff) | |
Imported Upstream snapshot 8.3~beta0+13298
Diffstat (limited to 'theories/FSets')
26 files changed, 3461 insertions, 8288 deletions
diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 8cb1236e..8158324e 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -1,4 +1,3 @@ - (***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) @@ -9,13 +8,13 @@ (* Finite map library. *) -(* $Id: FMapAVL.v 11033 2008-06-01 22:56:50Z letouzey $ *) +(* $Id$ *) (** * FMapAVL *) (** This module implements maps using AVL trees. - It follows the implementation from Ocaml's standard library. - + It follows the implementation from Ocaml's standard library. + See the comments at the beginning of FSetAVL for more details. *) @@ -30,8 +29,8 @@ Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. (** * The Raw functor - - Functor of pure functions + separate proofs of invariant + + Functor of pure functions + separate proofs of invariant preservation *) Module Raw (Import I:Int)(X: OrderedType). @@ -85,20 +84,20 @@ Definition is_empty m := match m with Leaf => true | _ => false end. to achieve logarithmic complexity. *) Fixpoint mem x m : bool := - match m with - | Leaf => false - | Node l y _ r _ => match X.compare x y with - | LT _ => mem x l + match m with + | Leaf => false + | Node l y _ r _ => match X.compare x y with + | LT _ => mem x l | EQ _ => true | GT _ => mem x r end end. -Fixpoint find x m : option elt := - match m with - | Leaf => None - | Node l y d r _ => match X.compare x y with - | LT _ => find x l +Fixpoint find x m : option elt := + match m with + | Leaf => None + | Node l y d r _ => match X.compare x y with + | LT _ => find x l | EQ _ => Some d | GT _ => find x r end @@ -109,7 +108,7 @@ Fixpoint find x m : option elt := (** [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 := +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 @@ -117,45 +116,45 @@ Definition create l x e r := Definition assert_false := create. -Fixpoint bal l x d r := - let hl := height l in +Fixpoint bal l x d r := + let hl := height l in let hr := height r in - if gt_le_dec hl (hr+2) then - match l with + if gt_le_dec hl (hr+2) then + match l with | Leaf => assert_false l x d r - | Node ll lx ld lr _ => - if ge_lt_dec (height ll) (height lr) then + | Node ll lx ld lr _ => + if ge_lt_dec (height ll) (height lr) then create ll lx ld (create lr x d r) - else - match lr with + else + match lr with | Leaf => assert_false l x d r - | Node lrl lrx lrd lrr _ => + | Node lrl lrx lrd lrr _ => create (create ll lx ld lrl) lrx lrd (create lrr x d r) end end - else - if gt_le_dec hr (hl+2) then + else + if gt_le_dec hr (hl+2) then match r with | Leaf => assert_false l x d r | Node rl rx rd rr _ => - if ge_lt_dec (height rr) (height rl) then + if ge_lt_dec (height rr) (height rl) then create (create l x d rl) rx rd rr - else + 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) + | Node rll rlx rld rlr _ => + create (create l x d rll) rlx rld (create rlr rx rd rr) end end - else + else create l x d r. (** * Insertion *) -Fixpoint add x d m := - match m with +Fixpoint add x d m := + match m with | Leaf => Node Leaf x d Leaf 1 - | Node l y d' r h => + | Node l y d' r h => match X.compare x y with | LT _ => bal (add x d l) y d' r | EQ _ => Node l y d r h @@ -165,16 +164,16 @@ Fixpoint add x d m := (** * 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]). + 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) := + +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 + | Node ll lx ld lr lh => + let (l',m) := remove_min ll lx ld lr in (bal l' x d r, m) end. @@ -185,18 +184,18 @@ Fixpoint remove_min l x d r : t*(key*elt) := [|height t1 - height t2| <= 2]. *) -Fixpoint merge s1 s2 := match s1,s2 with - | Leaf, _ => s2 +Fixpoint merge s1 s2 := match s1,s2 with + | Leaf, _ => s2 | _, Leaf => s1 - | _, Node l2 x2 d2 r2 h2 => - match remove_min l2 x2 d2 r2 with + | _, Node l2 x2 d2 r2 h2 => + match remove_min l2 x2 d2 r2 with (s2',(x,d)) => bal s1 x d s2' end end. (** * Deletion *) -Fixpoint remove x m := match m with +Fixpoint remove x m := match m with | Leaf => Leaf | Node l y d r h => match X.compare x y with @@ -206,26 +205,26 @@ Fixpoint remove x m := match m with end end. -(** * join - - Same as [bal] but does not assume anything regarding heights of [l] +(** * 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 + | 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 => + | Node rl rx rd rr rh => if gt_le_dec lh (rh+2) then bal ll lx ld (join lr x d r) - else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr + else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rd rr else create l x d r end end. -(** * Splitting +(** * Splitting [split x m] returns a triple [(l, o, r)] where - [l] is the set of elements of [m] that are [< x] @@ -236,17 +235,17 @@ Fixpoint join l : key -> elt -> t -> t := 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 +Fixpoint split x m : triple := match m with | Leaf => << Leaf, None, Leaf >> - | Node l y d r h => - match X.compare x y with + | 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 +(** * Concatenation Same as [merge] but does not assume anything about heights. *) @@ -256,7 +255,7 @@ Definition concat m1 m2 := | Leaf, _ => m2 | _ , Leaf => m1 | _, Node l2 x2 d2 r2 _ => - let (m2',xd) := remove_min l2 x2 d2 r2 in + let (m2',xd) := remove_min l2 x2 d2 r2 in join m1 xd#1 xd#2 m2' end. @@ -277,7 +276,7 @@ Definition elements := elements_aux nil. (** * Fold *) -Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A := +Fixpoint fold (A : Type) (f : key -> elt -> A -> A) (m : t) : A -> A := fun a => match m with | Leaf => a | Node l x d r _ => fold f r (f x d (fold f l a)) @@ -293,11 +292,11 @@ Inductive enumeration := | End : enumeration | More : key -> elt -> t -> enumeration -> enumeration. -(** [cons m e] adds the elements of tree [m] on the head of +(** [cons m e] adds the elements of tree [m] on the head of enumeration [e]. *) -Fixpoint cons m e : enumeration := - match m with +Fixpoint cons m e : enumeration := + match m with | Leaf => e | Node l x d r h => cons l (More x d r e) end. @@ -316,7 +315,7 @@ Definition equal_more x1 d1 (cont:enumeration->bool) e2 := (** Comparison of left tree, middle element, then right tree *) -Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := +Fixpoint equal_cont m1 (cont:enumeration->bool) e2 := match m1 with | Leaf => cont e2 | Node l1 x1 d1 r1 _ => @@ -341,8 +340,8 @@ 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 +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. @@ -350,7 +349,7 @@ Fixpoint map (elt elt' : Type)(f : elt -> elt')(m : t elt) : t elt' := (* * Mapi *) Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := - match m with + match m with | Leaf => Leaf _ | Node l x d r h => Node (mapi f l) x (f x d) (mapi f r) h end. @@ -358,28 +357,28 @@ Fixpoint mapi (elt elt' : Type)(f : key -> elt -> elt')(m : t elt) : t elt' := (** * Map with removal *) Fixpoint map_option (elt elt' : Type)(f : key -> elt -> option elt')(m : t elt) - : t elt' := - match m with + : t elt' := + match m with | Leaf => Leaf _ - | Node l x d r h => - match f x d with + | Node l x d r h => + match f x d with | Some d' => join (map_option f l) x d' (map_option f r) | None => concat (map_option f l) (map_option f r) end end. (** * Optimized map2 - - Suggestion by B. Gregoire: a [map2] function with specialized - arguments allowing to bypass some tree traversal. Instead of one - [f0] of type [key -> option elt -> option elt' -> option elt''], - we ask here for: + + Suggestion by B. Gregoire: a [map2] function with specialized + arguments allowing to bypass 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). + The idea is that [mapl] and [mapr] can be instantaneous (e.g. + the identity or some constant function). *) Section Map2_opt. @@ -388,13 +387,13 @@ Variable f : key -> elt -> option elt' -> option elt''. Variable mapl : t elt -> t elt''. Variable mapr : t elt' -> t elt''. -Fixpoint map2_opt m1 m2 := - match m1, m2 with - | Leaf, _ => mapr m2 +Fixpoint map2_opt m1 m2 := + match m1, m2 with + | Leaf, _ => mapr m2 | _, Leaf => mapl m1 - | Node l1 x1 d1 r1 h1, _ => + | Node l1 x1 d1 r1 h1, _ => let (l2',o2,r2') := split x1 m2 in - match f x1 d1 o2 with + match f x1 d1 o2 with | Some e => join (map2_opt l1 l2') x1 e (map2_opt r1 r2') | None => concat (map2_opt l1 l2') (map2_opt r1 r2') end @@ -403,8 +402,8 @@ Fixpoint map2_opt m1 m2 := End Map2_opt. (** * Map2 - - The [map2] function of the Map interface can be implemented + + The [map2] function of the Map interface can be implemented via [map2_opt] and [map_option]. *) @@ -412,8 +411,8 @@ Section Map2. Variable elt elt' elt'' : Type. Variable f : option elt -> option elt' -> option elt''. -Definition map2 : t elt -> t elt' -> t elt'' := - map2_opt +Definition map2 : t elt -> t elt' -> t elt'' := + map2_opt (fun _ d o => f (Some d) o) (map_option (fun _ d => f (Some d) None)) (map_option (fun _ d' => f None (Some d'))). @@ -432,24 +431,24 @@ Variable elt : Type. 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', + | 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', + | 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', + | 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', + | InRight : forall l r h y e', In x r -> In x (Node l y e' r h). Definition In0 k m := exists e:elt, MapsTo k e m. (** ** Binary search trees *) -(** [lt_tree x s]: all elements in [s] are smaller than [x] +(** [lt_tree x s]: all elements in [s] are smaller than [x] (resp. greater for [gt_tree]) *) Definition lt_tree x m := forall y, In y m -> X.lt y x. @@ -459,7 +458,7 @@ Definition gt_tree x m := forall y, In y m -> X.lt x y. Inductive bst : t elt -> Prop := | BSLeaf : bst (Leaf _) - | BSNode : forall x e l r h, bst l -> bst r -> + | BSNode : forall x e l r h, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (Node l x e r h). End Invariants. @@ -474,10 +473,10 @@ Module Proofs. 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 bal_ind := Induction for bal Sort Prop. Functional Scheme add_ind := Induction for add Sort Prop. Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. -Functional Scheme merge_ind := Induction for merge Sort Prop. +Functional Scheme merge_ind := Induction for merge Sort Prop. Functional Scheme remove_ind := Induction for remove Sort Prop. Functional Scheme concat_ind := Induction for concat Sort Prop. Functional Scheme split_ind := Induction for split Sort Prop. @@ -489,24 +488,24 @@ Functional Scheme map2_opt_ind := Induction for map2_opt Sort Prop. Hint Constructors tree MapsTo In bst. Hint Unfold lt_tree gt_tree. -Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) - "as" ident(s) := +Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) + "as" ident(s) := set (s:=Node l x d r h) in *; clearbody s; clear l x d r h. (** A tactic for cleaning hypothesis after use of functional induction. *) Ltac clearf := - match goal with + match goal with | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf | _ => idtac end. -(** A tactic to repeat [inversion_clear] on all hyps of the +(** A tactic to repeat [inversion_clear] on all hyps of the form [(f (Node ...))] *) Ltac inv f := - match goal with + 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 @@ -518,8 +517,8 @@ Ltac inv f := | _ => idtac end. -Ltac inv_all f := - match goal with +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 @@ -529,7 +528,7 @@ Ltac inv_all f := (** Helper tactic concerning order of elements. *) -Ltac order := match goal with +Ltac order := match goal with | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order | _ => MX.order @@ -537,21 +536,21 @@ end. Ltac intuition_in := repeat progress (intuition; inv In; inv MapsTo). -(* Function/Functional Scheme can't deal with internal fix. +(* Function/Functional Scheme can't deal with internal fix. Let's do its job by hand: *) -Ltac join_tac := - intros l; induction l as [| ll _ lx ld lr Hlr lh]; +Ltac join_tac := + intros l; induction l as [| ll _ lx ld lr Hlr lh]; [ | intros x d r; induction r as [| rl Hrl rx rd rr _ rh]; unfold join; - [ | destruct (gt_le_dec lh (rh+2)); + [ | destruct (gt_le_dec lh (rh+2)); [ match goal with |- context [ bal ?u ?v ?w ?z ] => - replace (bal u v w z) + replace (bal u v w z) with (bal ll lx ld (join lr x d (Node rl rx rd rr rh))); [ | auto] - end - | destruct (gt_le_dec rh (lh+2)); - [ match goal with |- context [ bal ?u ?v ?w ?z ] => - replace (bal u v w z) - with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] + end + | destruct (gt_le_dec rh (lh+2)); + [ match goal with |- context [ bal ?u ?v ?w ?z ] => + replace (bal u v w z) + with (bal (join (Node ll lx ld lr lh) x d rl) rx rd rr); [ | auto] end | ] ] ] ]; intros. @@ -575,7 +574,7 @@ Proof. Qed. Lemma In_alt : forall k m, In0 k m <-> In k m. -Proof. +Proof. split. intros (e,H); eauto. unfold In0; apply In_MapsTo; auto. @@ -588,14 +587,14 @@ Proof. Qed. Hint Immediate MapsTo_1. -Lemma In_1 : +Lemma In_1 : forall m x y, X.eq x y -> In x m -> In y m. Proof. intros m x y; induction m; simpl; intuition_in; eauto. Qed. -Lemma In_node_iff : - forall l x e r h y, +Lemma In_node_iff : + forall l x e r h y, In y (Node l x e r h) <-> In y l \/ X.eq y x \/ In y r. Proof. intuition_in. @@ -613,7 +612,7 @@ Proof. unfold gt_tree in |- *; intros; intuition_in. Qed. -Lemma lt_tree_node : forall x y l r e h, +Lemma lt_tree_node : forall x y l r e h, lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y e r h). Proof. unfold lt_tree in *; intuition_in; order. @@ -627,25 +626,25 @@ Qed. Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. -Lemma lt_left : forall x y l r e h, +Lemma lt_left : forall x y l r e h, lt_tree x (Node l y e r h) -> lt_tree x l. Proof. intuition_in. Qed. -Lemma lt_right : forall x y l r e h, +Lemma lt_right : forall x y l r e h, lt_tree x (Node l y e r h) -> lt_tree x r. Proof. intuition_in. Qed. -Lemma gt_left : forall x y l r e h, +Lemma gt_left : forall x y l r e h, gt_tree x (Node l y e r h) -> gt_tree x l. Proof. intuition_in. Qed. -Lemma gt_right : forall x y l r e h, +Lemma gt_right : forall x y l r e h, gt_tree x (Node l y e r h) -> gt_tree x r. Proof. intuition_in. @@ -695,39 +694,39 @@ Qed. (** * Emptyness test *) -Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. +Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. Proof. destruct m as [|r x e l h]; simpl; auto. intro H; elim (H x e); auto. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. -Proof. +Proof. destruct m; simpl; intros; try discriminate; red; intuition_in. Qed. (** * Appartness *) Lemma mem_1 : forall m x, bst m -> In x m -> mem x m = true. -Proof. +Proof. intros m x; functional induction (mem x m); auto; intros; clearf; inv bst; intuition_in; order. Qed. -Lemma mem_2 : forall m x, mem x m = true -> In x m. -Proof. +Lemma mem_2 : forall m x, mem x m = true -> In x m. +Proof. intros m x; functional induction (mem x m); auto; intros; discriminate. Qed. Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e. -Proof. +Proof. intros m x; functional induction (find x m); auto; intros; clearf; - inv bst; intuition_in; simpl; auto; + inv bst; intuition_in; simpl; auto; try solve [order | absurd (X.lt x y); eauto | absurd (X.lt y x); eauto]. Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. -Proof. +Proof. intros m x; functional induction (find x m); subst; intros; clearf; try discriminate. constructor 2; auto. @@ -735,7 +734,7 @@ Proof. constructor 3; auto. Qed. -Lemma find_iff : forall m x e, bst m -> +Lemma find_iff : forall m x e, bst m -> (find x m = Some e <-> MapsTo x e m). Proof. split; auto using find_1, find_2. @@ -745,7 +744,7 @@ Lemma find_in : forall m x, find x m <> None -> In x m. Proof. intros. case_eq (find x m); [intros|congruence]. - apply MapsTo_In with e; apply find_2; auto. + apply MapsTo_In with e; apply find_2; auto. Qed. Lemma in_find : forall m x, bst m -> In x m -> find x m <> None. @@ -755,7 +754,7 @@ Proof. rewrite (find_1 H Hd); discriminate. Qed. -Lemma find_in_iff : forall m x, bst m -> +Lemma find_in_iff : forall m x, bst m -> (find x m <> None <-> In x m). Proof. split; auto using find_in, in_find. @@ -771,11 +770,11 @@ Proof. elim H0; apply find_in; congruence. Qed. -Lemma find_find : forall m m' x, - find x m = find x m' <-> +Lemma find_find : forall m m' x, + find x m = find x m' <-> (forall d, find x m = Some d <-> find x m' = Some d). Proof. - intros; destruct (find x m); destruct (find x m'); split; intros; + intros; destruct (find x m); destruct (find x m'); split; intros; try split; try congruence. rewrite H; auto. symmetry; rewrite <- H; auto. @@ -783,7 +782,7 @@ Proof. Qed. Lemma find_mapsto_equiv : forall m m' x, bst m -> bst m' -> - (find x m = find x m' <-> + (find x m = find x m' <-> (forall d, MapsTo x d m <-> MapsTo x d m')). Proof. intros m m' x Hm Hm'. @@ -793,8 +792,8 @@ Proof. rewrite 2 find_iff; auto. Qed. -Lemma find_in_equiv : forall m m' x, bst m -> bst m' -> - find x m = find x m' -> +Lemma find_in_equiv : forall m m' x, bst m -> bst m' -> + find x m = find x m' -> (In x m <-> In x m'). Proof. split; intros; apply find_in; [ rewrite <- H1 | rewrite H1 ]; @@ -803,27 +802,27 @@ Qed. (** * Helper functions *) -Lemma create_bst : - forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> +Lemma create_bst : + forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (create l x e r). Proof. unfold create; auto. Qed. Hint Resolve create_bst. -Lemma create_in : - forall l x e r y, +Lemma create_in : + forall l x e r y, In y (create l x e r) <-> X.eq y x \/ In y l \/ In y r. Proof. unfold create; split; [ inversion_clear 1 | ]; intuition. Qed. -Lemma bal_bst : forall l x e r, bst l -> bst r -> +Lemma bal_bst : forall l x e r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (bal l x e r). Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv bst; repeat apply create_bst; auto; unfold create; try constructor; - (apply lt_tree_node || apply gt_tree_node); auto; + (apply lt_tree_node || apply gt_tree_node); auto; (eapply lt_tree_trans || eapply gt_tree_trans); eauto. Qed. Hint Resolve bal_bst. @@ -842,7 +841,7 @@ Proof. unfold assert_false, create; intuition_in. Qed. -Lemma bal_find : forall l x e r y, +Lemma bal_find : forall l x e r y, bst l -> bst r -> lt_tree x l -> gt_tree x r -> find y (bal l x e r) = find y (create l x e r). Proof. @@ -870,32 +869,32 @@ Qed. Hint Resolve add_bst. Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). -Proof. - intros m x y e; functional induction (add x e m); +Proof. + intros m x y e; functional induction (add x e m); intros; inv bst; try rewrite bal_mapsto; unfold create; eauto. Qed. -Lemma add_2 : forall m x y e e', ~X.eq x y -> +Lemma add_2 : forall m x y e e', ~X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m x y e e'; induction m; simpl; auto. destruct (X.compare x k); - intros; inv bst; try rewrite bal_mapsto; unfold create; auto; + intros; inv bst; try rewrite bal_mapsto; unfold create; auto; inv MapsTo; auto; order. Qed. -Lemma add_3 : forall m x y e e', ~X.eq x y -> +Lemma add_3 : forall m x y e e', ~X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. - intros m x y e e'; induction m; simpl; auto. + intros m x y e e'; induction m; simpl; auto. intros; inv MapsTo; auto; order. - destruct (X.compare x k); intro; - try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; + destruct (X.compare x k); intro; + try rewrite bal_mapsto; auto; unfold create; intros; inv MapsTo; auto; order. Qed. -Lemma add_find : forall m x y e, bst m -> - find y (add x e m) = +Lemma add_find : forall m x y e, bst m -> + find y (add x e m) = match X.compare y x with EQ _ => Some e | _ => find y m end. Proof. intros. @@ -909,7 +908,7 @@ Qed. (** * Extraction of minimum binding *) Lemma remove_min_in : forall l x e r h y, - In y (Node l x e r h) <-> + In y (Node l x e r h) <-> X.eq y (remove_min l x e r)#2#1 \/ In y (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. @@ -919,7 +918,7 @@ Proof. Qed. Lemma remove_min_mapsto : forall l x e r h y e', - MapsTo y e' (Node l x e r h) <-> + MapsTo y e' (Node l x e r h) <-> ((X.eq y (remove_min l x e r)#2#1) /\ e' = (remove_min l x e r)#2#2) \/ MapsTo y e' (remove_min l x e r)#1. Proof. @@ -933,7 +932,7 @@ Proof. inversion_clear H3; intuition. Qed. -Lemma remove_min_bst : forall l x e r h, +Lemma remove_min_bst : forall l x e r h, bst (Node l x e r h) -> bst (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. @@ -949,8 +948,8 @@ Proof. Qed. Hint Resolve remove_min_bst. -Lemma remove_min_gt_tree : forall l x e r h, - bst (Node l x e r h) -> +Lemma remove_min_gt_tree : forall l x e r h, + bst (Node l x e r h) -> gt_tree (remove_min l x e r)#2#1 (remove_min l x e r)#1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. @@ -968,10 +967,10 @@ Proof. Qed. Hint Resolve remove_min_gt_tree. -Lemma remove_min_find : forall l x e r h y, - bst (Node l x e r h) -> - find y (Node l x e r h) = - match X.compare y (remove_min l x e r)#2#1 with +Lemma remove_min_find : forall l x e r h y, + bst (Node l x e r h) -> + find y (Node l x e r h) = + match X.compare y (remove_min l x e r)#2#1 with | LT _ => None | EQ _ => Some (remove_min l x e r)#2#2 | GT _ => find y (remove_min l x e r)#1 @@ -990,9 +989,9 @@ Qed. (** * Merging two trees *) -Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 -> +Lemma merge_in : forall m1 m2 y, bst m1 -> bst m2 -> (In y (merge m1 m2) <-> In y m1 \/ In y m2). -Proof. +Proof. intros m1 m2; functional induction (merge m1 m2);intros; try factornode _x _x0 _x1 _x2 _x3 as m1. intuition_in. @@ -1000,10 +999,10 @@ Proof. rewrite bal_in, remove_min_in, e1; simpl; intuition. Qed. -Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 -> +Lemma merge_mapsto : forall m1 m2 y e, bst m1 -> bst m2 -> (MapsTo y e (merge m1 m2) <-> MapsTo y e m1 \/ MapsTo y e m2). Proof. - intros m1 m2; functional induction (merge m1 m2); intros; + intros m1 m2; functional induction (merge m1 m2); intros; try factornode _x _x0 _x1 _x2 _x3 as m1. intuition_in. intuition_in. @@ -1013,12 +1012,12 @@ Proof. inversion_clear H1; intuition. Qed. -Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 -> - (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> - bst (merge m1 m2). +Lemma merge_bst : forall m1 m2, bst m1 -> bst m2 -> + (forall y1 y2 : key, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> + bst (merge m1 m2). Proof. intros m1 m2; functional induction (merge m1 m2); intros; auto; - try factornode _x _x0 _x1 _x2 _x3 as m1. + try factornode _x _x0 _x1 _x2 _x3 as m1. apply bal_bst; auto. generalize (remove_min_bst H0); rewrite e1; simpl in *; auto. intro; intro. @@ -1029,7 +1028,7 @@ Qed. (** * Deletion *) -Lemma remove_in : forall m x y, bst m -> +Lemma remove_in : forall m x y, bst m -> (In y (remove x m) <-> ~ X.eq y x /\ In y m). Proof. intros m x; functional induction (remove x m); simpl; intros. @@ -1049,7 +1048,7 @@ Proof. Qed. Lemma remove_bst : forall m x, bst m -> bst (remove x m). -Proof. +Proof. intros m x; functional induction (remove x m); simpl; intros. auto. (* LT *) @@ -1061,7 +1060,7 @@ Proof. (* EQ *) inv bst. apply merge_bst; eauto. - (* GT *) + (* GT *) inv bst. apply bal_bst; auto. intro; intro. @@ -1070,16 +1069,16 @@ Proof. Qed. Lemma remove_1 : forall m x y, bst m -> X.eq x y -> ~ In y (remove x m). -Proof. +Proof. intros; rewrite remove_in; intuition. Qed. -Lemma remove_2 : forall m x y e, bst m -> ~X.eq x y -> +Lemma remove_2 : forall m x y e, bst m -> ~X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m x y e; induction m; simpl; auto. - destruct (X.compare x k); - intros; inv bst; try rewrite bal_mapsto; unfold create; auto; + destruct (X.compare x k); + intros; inv bst; try rewrite bal_mapsto; unfold create; auto; try solve [inv MapsTo; auto]. rewrite merge_mapsto; auto. inv MapsTo; auto; order. @@ -1089,7 +1088,7 @@ Lemma remove_3 : forall m x y e, bst m -> MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m x y e; induction m; simpl; auto. - destruct (X.compare x k); intros Bs; inv bst; + destruct (X.compare x k); intros Bs; inv bst; try rewrite bal_mapsto; auto; unfold create. intros; inv MapsTo; auto. rewrite merge_mapsto; intuition. @@ -1098,7 +1097,7 @@ Qed. (** * join *) -Lemma join_in : forall l x d r y, +Lemma join_in : forall l x d r y, In y (join l x d r) <-> X.eq y x \/ In y l \/ In y r. Proof. join_tac. @@ -1110,23 +1109,23 @@ Proof. apply create_in. Qed. -Lemma join_bst : forall l x d r, bst l -> bst r -> +Lemma join_bst : forall l x d r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> bst (join l x d r). Proof. - join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; + join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; clear Hrl Hlr z; intro; intros; rewrite join_in in *. intuition; [ apply MX.lt_eq with x | ]; eauto. intuition; [ apply MX.eq_lt with x | ]; eauto. Qed. Hint Resolve join_bst. -Lemma join_find : forall l x d r y, - bst l -> bst r -> lt_tree x l -> gt_tree x r -> +Lemma join_find : forall l x d r y, + bst l -> bst r -> lt_tree x l -> gt_tree x r -> find y (join l x d r) = find y (create l x d r). Proof. join_tac; auto; inv bst; - simpl (join (Leaf elt)); - try (assert (X.lt lx x) by auto); + simpl (join (Leaf elt)); + try (assert (X.lt lx x) by auto); try (assert (X.lt x rx) by auto); rewrite ?add_find, ?bal_find; auto. @@ -1150,10 +1149,10 @@ Qed. (** * split *) -Lemma split_in_1 : forall m x, bst m -> forall y, +Lemma split_in_1 : forall m x, bst m -> forall y, (In y (split x m)#l <-> In y m /\ X.lt y x). Proof. - intros m x; functional induction (split x m); simpl; intros; + intros m x; functional induction (split x m); simpl; intros; inv bst; try clear e0. intuition_in. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. @@ -1162,10 +1161,10 @@ Proof. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma split_in_2 : forall m x, bst m -> forall y, +Lemma split_in_2 : forall m x, bst m -> forall y, (In y (split x m)#r <-> In y m /\ X.lt x y). -Proof. - intros m x; functional induction (split x m); subst; simpl; intros; +Proof. + intros m x; functional induction (split x m); subst; simpl; intros; inv bst; try clear e0. intuition_in. rewrite join_in. @@ -1174,18 +1173,18 @@ Proof. rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. Qed. -Lemma split_in_3 : forall m x, bst m -> +Lemma split_in_3 : forall m x, bst m -> (split x m)#o = find x m. Proof. intros m x; functional induction (split x m); subst; simpl; auto; - intros; inv bst; try clear e0; - destruct X.compare; try (order;fail); rewrite <-IHt, e1; auto. + intros; inv bst; try clear e0; + destruct X.compare; try order; trivial; rewrite <- IHt, e1; auto. Qed. -Lemma split_bst : forall m x, bst m -> +Lemma split_bst : forall m x, bst m -> bst (split x m)#l /\ bst (split x m)#r. -Proof. - intros m x; functional induction (split x m); subst; simpl; intros; +Proof. + intros m x; functional induction (split x m); subst; simpl; intros; inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition; apply join_bst; auto. intros y0. @@ -1204,17 +1203,17 @@ Proof. intros m x B y Hy; rewrite split_in_2 in Hy; intuition. Qed. -Lemma split_find : forall m x y, bst m -> - find y m = match X.compare y x with +Lemma split_find : forall m x y, bst m -> + find y m = match X.compare y x with | LT _ => find y (split x m)#l | EQ _ => (split x m)#o | GT _ => find y (split x m)#r end. Proof. - intros m x; functional induction (split x m); subst; simpl; intros; - inv bst; try clear e0; try rewrite e1 in *; simpl in *; + intros m x; functional induction (split x m); subst; simpl; intros; + inv bst; try clear e0; try rewrite e1 in *; simpl in *; [ destruct X.compare; auto | .. ]; - try match goal with E:split ?x ?t = _, B:bst ?t |- _ => + try match goal with E:split ?x ?t = _, B:bst ?t |- _ => generalize (split_in_1 x B)(split_in_2 x B)(split_bst x B); rewrite E; simpl; destruct 3 end. @@ -1231,7 +1230,7 @@ Qed. (** * Concatenation *) -Lemma concat_in : forall m1 m2 y, +Lemma concat_in : forall m1 m2 y, In y (concat m1 m2) <-> In y m1 \/ In y m2. Proof. intros m1 m2; functional induction (concat m1 m2); intros; @@ -1241,11 +1240,11 @@ Proof. rewrite join_in, remove_min_in, e1; simpl; intuition. Qed. -Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 -> - (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> +Lemma concat_bst : forall m1 m2, bst m1 -> bst m2 -> + (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> bst (concat m1 m2). Proof. - intros m1 m2; functional induction (concat m1 m2); intros; auto; + intros m1 m2; functional induction (concat m1 m2); intros; auto; try factornode _x _x0 _x1 _x2 _x3 as m1. apply join_bst; auto. change (bst (m2',xd)#1); rewrite <-e1; eauto. @@ -1256,19 +1255,19 @@ Proof. Qed. Hint Resolve concat_bst. -Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> - (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> - find y (concat m1 m2) = +Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> + (forall y1 y2, In y1 m1 -> In y2 m2 -> X.lt y1 y2) -> + find y (concat m1 m2) = match find y m2 with Some d => Some d | None => find y m1 end. Proof. - intros m1 m2; functional induction (concat m1 m2); intros; auto; + intros m1 m2; functional induction (concat m1 m2); intros; auto; try factornode _x _x0 _x1 _x2 _x3 as m1. simpl; destruct (find y m2); auto. generalize (remove_min_find y H0)(remove_min_in l2 x2 d2 r2 _x4) - (remove_min_bst H0)(remove_min_gt_tree H0); + (remove_min_bst H0)(remove_min_gt_tree H0); rewrite e1; simpl fst; simpl snd; intros. - + inv bst. rewrite H2, join_find; auto; clear H2. simpl; destruct X.compare; simpl; auto. @@ -1286,7 +1285,7 @@ Notation eqk := (PX.eqk (elt:= elt)). Notation eqke := (PX.eqke (elt:= elt)). Notation ltk := (PX.ltk (elt:= elt)). -Lemma elements_aux_mapsto : forall (s:t elt) acc x e, +Lemma elements_aux_mapsto : forall (s:t elt) acc x e, InA eqke (x,e) (elements_aux acc s) <-> MapsTo x e s \/ InA eqke (x,e) acc. Proof. induction s as [ | l Hl x e r Hr h ]; simpl; auto. @@ -1299,8 +1298,8 @@ Proof. destruct H0; simpl in *; subst; intuition. Qed. -Lemma elements_mapsto : forall (s:t elt) x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. -Proof. +Lemma elements_mapsto : forall (s:t elt) x e, InA eqke (x,e) (elements s) <-> MapsTo x e s. +Proof. intros; generalize (elements_aux_mapsto s nil x e); intuition. inversion_clear H0. Qed. @@ -1324,9 +1323,9 @@ Proof. induction s as [ | l Hl y e r Hr h]; simpl; intuition. inv bst. apply Hl; auto. - constructor. + constructor. apply Hr; eauto. - apply (InA_InfA (PX.eqke_refl (elt:=elt))); intros (y',e') H6. + apply InA_InfA with (eqA:=eqke); auto with *. intros (y',e') H6. destruct (elements_aux_mapsto r acc y' e'); intuition. red; simpl; eauto. red; simpl; eauto. @@ -1382,7 +1381,7 @@ Qed. (** * Fold *) -Definition fold' (A : Type) (f : key -> elt -> A -> A)(s : t elt) := +Definition fold' (A : Type) (f : key -> elt -> A -> A)(s : t elt) := L.fold f (elements s). Lemma fold_equiv_aux : @@ -1401,14 +1400,14 @@ Lemma fold_equiv : forall (A : Type) (s : t elt) (f : key -> elt -> A -> A) (a : A), fold f s a = fold' f s a. Proof. - unfold fold', elements in |- *. + unfold fold', elements in |- *. simple induction s; simpl in |- *; auto; intros. rewrite fold_equiv_aux. rewrite H0. simpl in |- *; auto. Qed. -Lemma fold_1 : +Lemma fold_1 : forall (s:t elt)(Hs:bst s)(A : Type)(i:A)(f : key -> elt -> A -> A), fold f s i = fold_left (fun a p => f p#1 p#2 a) (elements s) i. Proof. @@ -1421,9 +1420,9 @@ Qed. (** * Comparison *) -(** [flatten_e e] returns the list of elements of the enumeration [e] +(** [flatten_e e] returns the list of elements of the enumeration [e] i.e. the list of elements actually compared *) - + Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with | End => nil | More x e t r => (x,e) :: elements t ++ flatten_e r @@ -1431,13 +1430,13 @@ Fixpoint flatten_e (e : enumeration elt) : list (key*elt) := match e with Lemma flatten_e_elements : forall (l:t elt) r x d z e, - elements l ++ flatten_e (More x d r e) = + elements l ++ flatten_e (More x d r e) = elements (Node l x d r z) ++ flatten_e e. Proof. intros; simpl; apply elements_node. Qed. -Lemma cons_1 : forall (s:t elt) e, +Lemma cons_1 : forall (s:t elt) e, flatten_e (cons s e) = elements s ++ flatten_e e. Proof. induction s; simpl; auto; intros. @@ -1450,24 +1449,24 @@ 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 -> +Lemma cons_IfEq : forall b x1 x2 d1 d2 l1 l2, + X.eq x1 x2 -> cmp d1 d2 = true -> + IfEq b l1 l2 -> IfEq b ((x1,d1)::l1) ((x2,d2)::l2). Proof. - unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl; + unfold IfEq; destruct b; simpl; intros; destruct X.compare; simpl; try rewrite H0; auto; order. Qed. -Lemma equal_end_IfEq : forall e2, +Lemma equal_end_IfEq : forall e2, IfEq (equal_end e2) nil (flatten_e e2). Proof. destruct e2; red; auto. Qed. -Lemma equal_more_IfEq : - forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, - IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> +Lemma equal_more_IfEq : + forall x1 d1 (cont:enumeration elt -> bool) x2 d2 r2 e2 l, + IfEq (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> IfEq (equal_more cmp x1 d1 cont (More x2 d2 r2 e2)) ((x1,d1)::l) (flatten_e (More x2 d2 r2 e2)). Proof. @@ -1475,7 +1474,7 @@ Proof. rewrite <-andb_lazy_alt; f_equal; auto. Qed. -Lemma equal_cont_IfEq : forall m1 cont e2 l, +Lemma equal_cont_IfEq : forall m1 cont e2 l, (forall e, IfEq (cont e) l (flatten_e e)) -> IfEq (equal_cont cmp m1 cont e2) (elements m1 ++ l) (flatten_e e2). Proof. @@ -1493,18 +1492,18 @@ Lemma equal_IfEq : forall (m1 m2:t elt), Proof. intros; unfold equal. rewrite (app_nil_end (elements m1)). - replace (elements m2) with (flatten_e (cons m2 (End _))) + replace (elements m2) with (flatten_e (cons m2 (End _))) by (rewrite cons_1; simpl; rewrite <-app_nil_end; auto). apply equal_cont_IfEq. intros. apply equal_end_IfEq; auto. Qed. -Definition Equivb m m' := - (forall k, In k m <-> In k m') /\ +Definition Equivb m m' := + (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Lemma Equivb_elements : forall s s', +Lemma Equivb_elements : forall s s', Equivb s s' <-> L.Equivb cmp (elements s) (elements s'). Proof. unfold Equivb, L.Equivb; split; split; intros. @@ -1516,7 +1515,7 @@ destruct H. apply (H2 k); unfold L.PX.MapsTo; rewrite elements_mapsto; auto. Qed. -Lemma equal_Equivb : forall (s s': t elt), bst s -> bst s' -> +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'. @@ -1526,17 +1525,17 @@ Qed. End Elt. -Section Map. +Section Map. Variable elt elt' : Type. -Variable f : elt -> elt'. +Variable f : elt -> elt'. -Lemma map_1 : forall (m: t elt)(x:key)(e:elt), +Lemma map_1 : forall (m: t elt)(x:key)(e:elt), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. induction m; simpl; inversion_clear 1; auto. Qed. -Lemma map_2 : forall (m: t elt)(x:key), +Lemma map_2 : forall (m: t elt)(x:key), In x (map f m) -> In x m. Proof. induction m; simpl; inversion_clear 1; auto. @@ -1545,7 +1544,7 @@ Qed. Lemma map_bst : forall m, bst m -> bst (map f m). Proof. induction m; simpl; auto. -inversion_clear 1; constructor; auto; +inversion_clear 1; constructor; auto; red; auto using map_2. Qed. @@ -1554,7 +1553,7 @@ Section Mapi. Variable elt elt' : Type. Variable f : key -> elt -> elt'. -Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), +Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. induction m; simpl; inversion_clear 1; auto. @@ -1565,7 +1564,7 @@ destruct (IHm2 _ _ H0). exists x0; intuition. Qed. -Lemma mapi_2 : forall (m: t elt)(x:key), +Lemma mapi_2 : forall (m: t elt)(x:key), In x (mapi f m) -> In x m. Proof. induction m; simpl; inversion_clear 1; auto. @@ -1574,7 +1573,7 @@ Qed. Lemma mapi_bst : forall m, bst m -> bst (mapi f m). Proof. induction m; simpl; auto. -inversion_clear 1; constructor; auto; +inversion_clear 1; constructor; auto; red; auto using mapi_2. Qed. @@ -1585,7 +1584,7 @@ Variable elt elt' : Type. Variable f : key -> elt -> option elt'. Hypothesis f_compat : forall x x' d, X.eq x x' -> f x d = f x' d. -Lemma map_option_2 : forall (m:t elt)(x:key), +Lemma map_option_2 : forall (m:t elt)(x:key), In x (map_option f m) -> exists d, MapsTo x d m /\ f x d <> None. Proof. intros m; functional induction (map_option f m); simpl; auto; intros. @@ -1601,9 +1600,9 @@ Qed. Lemma map_option_bst : forall m, bst m -> bst (map_option f m). Proof. -intros m; functional induction (map_option f m); simpl; auto; intros; +intros m; functional induction (map_option f m); simpl; auto; intros; inv bst. -apply join_bst; auto; intros y H; +apply join_bst; auto; intros y H; destruct (map_option_2 H) as (d0 & ? & ?); eauto using MapsTo_In. apply concat_bst; auto; intros y y' H H'. destruct (map_option_2 H) as (d0 & ? & ?). @@ -1612,22 +1611,22 @@ eapply X.lt_trans with x; eauto using MapsTo_In. Qed. Hint Resolve map_option_bst. -Ltac nonify e := - replace e with (@None elt) by +Ltac nonify e := + replace e with (@None elt) by (symmetry; rewrite not_find_iff; auto; intro; order). -Lemma map_option_find : forall (m:t elt)(x:key), - bst m -> - find x (map_option f m) = +Lemma map_option_find : forall (m:t elt)(x:key), + bst m -> + find x (map_option f m) = match (find x m) with Some d => f x d | None => None end. Proof. intros m; functional induction (map_option f m); simpl; auto; intros; - inv bst; rewrite join_find || rewrite concat_find; auto; simpl; + inv bst; rewrite join_find || rewrite concat_find; auto; simpl; try destruct X.compare; simpl; auto. rewrite (f_compat d e); auto. intros y H; destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In. -intros y H; +intros y H; destruct (map_option_2 H) as (? & ? & ?); eauto using MapsTo_In. rewrite <- IHt, IHt0; auto; nonify (find x0 r); auto. @@ -1653,21 +1652,21 @@ Variable mapr : t elt' -> t elt''. Hypothesis f0_f : forall x d o, f x d o = f0 x (Some d) o. Hypothesis mapl_bst : forall m, bst m -> bst (mapl m). Hypothesis mapr_bst : forall m', bst m' -> bst (mapr m'). -Hypothesis mapl_f0 : forall x m, bst m -> - find x (mapl m) = +Hypothesis mapl_f0 : forall x m, bst m -> + find x (mapl m) = match find x m with Some d => f0 x (Some d) None | None => None end. -Hypothesis mapr_f0 : forall x m', bst m' -> - find x (mapr m') = +Hypothesis mapr_f0 : forall x m', bst m' -> + find x (mapr m') = match find x m' with Some d' => f0 x None (Some d') | None => None end. Hypothesis f0_compat : forall x x' o o', X.eq x x' -> f0 x o o' = f0 x' o o'. Notation map2_opt := (map2_opt f mapl mapr). -Lemma map2_opt_2 : forall m m' y, bst m -> bst m' -> +Lemma map2_opt_2 : forall m m' y, bst m -> bst m' -> In y (map2_opt m m') -> In y m \/ In y m'. Proof. intros m m'; functional induction (map2_opt m m'); intros; - auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; + auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; try (generalize (split_in_1 x1 H0 y)(split_in_2 x1 H0 y) (split_bst x1 H0); rewrite e1; simpl; destruct 3; inv bst). @@ -1689,12 +1688,12 @@ destruct (IHt1 y H6 H4 H'); intuition. destruct (IHt0 y H7 H5 H'); intuition. Qed. -Lemma map2_opt_bst : forall m m', bst m -> bst m' -> +Lemma map2_opt_bst : forall m m', bst m -> bst m' -> bst (map2_opt m m'). Proof. intros m m'; functional induction (map2_opt m m'); intros; - auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst; - generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0); + auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; inv bst; + generalize (split_in_1 x1 H0)(split_in_2 x1 H0)(split_bst x1 H0); rewrite e1; simpl in *; destruct 3. apply join_bst; auto. @@ -1711,31 +1710,31 @@ destruct (map2_opt_2 H2 H7 Hy'); intuition. Qed. Hint Resolve map2_opt_bst. -Ltac map2_aux := +Ltac map2_aux := match goal with - | H : In ?x _ \/ In ?x ?m, - H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ => - destruct H; [ intuition_in; order | + | H : In ?x _ \/ In ?x ?m, + H' : find ?x ?m = find ?x ?m', B:bst ?m, B':bst ?m' |- _ => + destruct H; [ intuition_in; order | rewrite <-(find_in_equiv B B' H'); auto ] end. -Ltac nonify t := - match t with (find ?y (map2_opt ?m ?m')) => +Ltac nonify t := + match t with (find ?y (map2_opt ?m ?m')) => replace t with (@None elt''); [ | symmetry; rewrite not_find_iff; auto; intro; destruct (@map2_opt_2 m m' y); auto; order ] end. -Lemma map2_opt_1 : forall m m' y, bst m -> bst m' -> +Lemma map2_opt_1 : forall m m' y, bst m -> bst m' -> In y m \/ In y m' -> find y (map2_opt m m') = f0 y (find y m) (find y m'). Proof. intros m m'; functional induction (map2_opt m m'); intros; - auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; + auto; try factornode _x0 _x1 _x2 _x3 _x4 as m2; try (generalize (split_in_1 x1 H0)(split_in_2 x1 H0) (split_in_3 x1 H0)(split_bst x1 H0)(split_find x1 y H0) (split_lt_tree (x:=x1) H0)(split_gt_tree (x:=x1) H0); - rewrite e1; simpl in *; destruct 4; intros; inv bst; + rewrite e1; simpl in *; destruct 4; intros; inv bst; subst o2; rewrite H7, ?join_find, ?concat_find; auto). simpl; destruct H1; [ inversion_clear H1 | ]. @@ -1777,23 +1776,23 @@ Variable f : option elt -> option elt' -> option elt''. Lemma map2_bst : forall m m', bst m -> bst m' -> bst (map2 f m m'). Proof. unfold map2; intros. -apply map2_opt_bst with (fun _ => f); auto using map_option_bst; +apply map2_opt_bst with (fun _ => f); auto using map_option_bst; intros; rewrite map_option_find; auto. Qed. -Lemma map2_1 : forall m m' y, bst m -> bst m' -> +Lemma map2_1 : forall m m' y, bst m -> bst m' -> In y m \/ In y m' -> find y (map2 f m m') = f (find y m) (find y m'). Proof. unfold map2; intros. -rewrite (map2_opt_1 (f0:=fun _ => f)); +rewrite (map2_opt_1 (f0:=fun _ => f)); auto using map_option_bst; intros; rewrite map_option_find; auto. Qed. -Lemma map2_2 : forall m m' y, bst m -> bst m' -> +Lemma map2_2 : forall m m' y, bst m -> bst m' -> In y (map2 f m m') -> In y m \/ In y m'. Proof. unfold map2; intros. -eapply map2_opt_2 with (f0:=fun _ => f); eauto; intros. +eapply map2_opt_2 with (f0:=fun _ => f); try eassumption; trivial; intros. apply map_option_bst; auto. apply map_option_bst; auto. rewrite map_option_find; auto. @@ -1806,38 +1805,38 @@ End Raw. (** * Encapsulation - Now, in order to really provide a functor implementing [S], we + 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. + Module Raw := Raw I X. Import Raw.Proofs. - Record bst (elt:Type) := + Record bst (elt:Type) := Bst {this :> Raw.tree elt; is_bst : Raw.bst this}. - - Definition t := bst. + + Definition t := bst. Definition key := E.t. - - Section Elt. + + Section Elt. Variable elt elt' elt'': Type. Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. + Implicit Types x y : key. + Implicit Types e : elt. Definition empty : t elt := Bst (empty_bst elt). Definition is_empty m : bool := Raw.is_empty m.(this). Definition add x e m : t elt := Bst (add_bst x e m.(is_bst)). - Definition remove x m : t elt := Bst (remove_bst x m.(is_bst)). + Definition remove x m : t elt := Bst (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' := Bst (map_bst f m.(is_bst)). - Definition mapi (f:key->elt->elt') m : t elt' := + Definition mapi (f:key->elt->elt') m : t elt' := Bst (mapi_bst f m.(is_bst)). - Definition map2 f m (m':t elt') : t elt'' := + Definition map2 f m (m':t elt') : t elt'' := Bst (map2_bst f m.(is_bst) m'.(is_bst)). Definition elements m : list (key*elt) := Raw.elements m.(this). Definition cardinal m := Raw.cardinal m.(this). @@ -1854,14 +1853,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. - + Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. apply m.(is_bst). Qed. - - Lemma mem_2 : forall m x, mem x m = true -> In x m. + + Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto. Qed. @@ -1892,7 +1891,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@find_2 elt m.(this)). Qed. @@ -1901,36 +1900,36 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. - Lemma elements_1 : forall m x e, + Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto. Qed. - Lemma elements_2 : forall m x e, + Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto. Qed. - Lemma elements_3 : forall m, sort lt_key (elements m). + Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intro m; exact (@elements_cardinal elt m.(this)). 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') /\ + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp := Equiv (Cmp cmp). - Lemma Equivb_Equivb : forall cmp m m', + Lemma Equivb_Equivb : forall cmp m m', Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. - Proof. + Proof. intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. @@ -1938,23 +1937,23 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. generalize (H0 k); do 2 rewrite <- In_alt; intuition. Qed. - Lemma equal_1 : forall m m' cmp, - Equivb cmp m m' -> equal cmp m m' = true. - Proof. - unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; + Lemma equal_1 : forall m m' cmp, + Equivb cmp m m' -> equal cmp m m' = true. + Proof. + unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite equal_Equivb; auto. - Qed. + Qed. - Lemma equal_2 : forall m m' cmp, + Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. - unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; + Proof. + unfold equal; intros (m,b) (m',b') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite <-equal_Equivb; auto. Qed. End Elt. - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. @@ -1962,10 +1961,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl. apply map_2; auto. - Qed. + Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) @@ -1975,10 +1974,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. apply m.(is_bst). @@ -1986,9 +1985,9 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - Proof. + Proof. unfold In, map2; intros elt elt' elt'' m m' x f. do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. apply m.(is_bst). @@ -1998,19 +1997,19 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. End IntMake. -Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: - Sord with Module Data := D +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 Import MapS := IntMake(I)(X). Module LO := FMapList.Make_ord(X)(D). Module R := Raw. Module P := Raw.Proofs. Definition t := MapS.t D.t. - Definition cmp e e' := + Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. (** One step of comparison of elements *) @@ -2020,9 +2019,9 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: | R.End => Gt | R.More x2 d2 r2 e2 => match X.compare x1 x2 with - | EQ _ => match D.compare d1 d2 with + | EQ _ => match D.compare d1 d2 with | EQ _ => cont (R.cons r2 e2) - | LT _ => Lt + | LT _ => Lt | GT _ => Gt end | LT _ => Lt @@ -2046,7 +2045,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: (** The complete comparison *) - Definition compare_pure s1 s2 := + Definition compare_pure s1 s2 := compare_cont s1 compare_end (R.cons s2 (Raw.End _)). (** Correctness of this comparison *) @@ -2058,7 +2057,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: | Gt => (fun l1 l2 => LO.lt_list l2 l1) end. - Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, + Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, X.eq x1 x2 -> D.eq d1 d2 -> Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). Proof. @@ -2077,10 +2076,10 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Cmp (compare_more x1 d1 cont (R.More x2 d2 r2 e2)) ((x1,d1)::l) (P.flatten_e (R.More x2 d2 r2 e2)). Proof. - simpl; intros; destruct X.compare; simpl; + simpl; intros; destruct X.compare; simpl; try destruct D.compare; simpl; auto; P.MX.elim_comp; auto. Qed. - + Lemma compare_cont_Cmp : forall s1 cont e2 l, (forall e, Cmp (cont e) l (P.flatten_e e)) -> Cmp (compare_cont s1 cont e2) (R.elements s1 ++ l) (P.flatten_e e2). @@ -2110,14 +2109,14 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Definition compare (s s':t) : Compare lt eq s s'. Proof. - intros (s,b) (s',b'). + destruct s as (s,b), s' as (s',b'). generalize (compare_Cmp s s'). destruct compare_pure; intros; [apply EQ|apply LT|apply GT]; red; auto. Defined. - + (* Proofs about [eq] and [lt] *) - Definition selements (m1 : t) := + Definition selements (m1 : t) := LO.MapS.Build_slist (P.elements_sort m1.(is_bst)). Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). @@ -2154,7 +2153,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Qed. Lemma eq_refl : forall m : t, eq m m. - Proof. + Proof. intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl. Qed. @@ -2171,13 +2170,13 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Proof. - intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; + intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; intros; eapply LO.lt_trans; eauto. Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. - intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; + intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; intros; apply LO.lt_not_eq; auto. Qed. @@ -2188,8 +2187,8 @@ End IntMake_ord. 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 +Module Make_ord (X: OrderedType)(D: OrderedType) + <: Sord with Module Data := D with Module MapS.E := X :=IntMake_ord(Z_as_Int)(X)(D). diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index d91eb87a..4c59971c 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -6,25 +6,22 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapFacts.v 12187 2009-06-13 19:36:59Z msozeau $ *) +(* $Id$ *) (** * Finite maps library *) (** This functor derives additional facts from [FMapInterface.S]. These - facts are mainly the specifications of [FMapInterface.S] written using - different styles: equivalence and boolean equalities. + facts are mainly the specifications of [FMapInterface.S] written using + different styles: equivalence and boolean equalities. *) Require Import Bool DecidableType DecidableTypeEx OrderedType Morphisms. -Require Export FMapInterface. +Require Export FMapInterface. Set Implicit Arguments. Unset Strict Implicit. Hint Extern 1 (Equivalence _) => constructor; congruence. -Notation Leibniz := (@eq _) (only parsing). - - (** * Facts about weak maps *) Module WFacts_fun (E:DecidableType)(Import M:WSfun E). @@ -46,7 +43,7 @@ destruct o; destruct o'; try rewrite H; auto. symmetry; rewrite <- H; auto. Qed. -Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), +Lemma MapsTo_fun : forall (elt:Type) m x (e e':elt), MapsTo x e m -> MapsTo x e' m -> e=e'. Proof. intros. @@ -56,7 +53,7 @@ Qed. (** ** Specifications written using equivalences *) -Section IffSpec. +Section IffSpec. Variable elt elt' elt'': Type. Implicit Type m: t elt. Implicit Type x y z: key. @@ -101,7 +98,7 @@ Lemma not_find_in_iff : forall m x, ~In x m <-> find x m = None. Proof. split; intros. rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff. -split; intro H'; try discriminate. elim H; exists e; auto. +split; try discriminate. intro H'; elim H; exists e; auto. intros (e,He); rewrite find_mapsto_iff,H in He; discriminate. Qed. @@ -112,7 +109,7 @@ destruct mem; intuition. Qed. Lemma equal_iff : forall m m' cmp, Equivb cmp m m' <-> equal cmp m m' = true. -Proof. +Proof. split; [apply equal_1|apply equal_2]. Qed. @@ -127,16 +124,16 @@ unfold In. split; [intros (e,H); rewrite empty_mapsto_iff in H|]; intuition. Qed. -Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. -Proof. +Lemma is_empty_iff : forall m, Empty m <-> is_empty m = true. +Proof. split; [apply is_empty_1|apply is_empty_2]. Qed. -Lemma add_mapsto_iff : forall m x y e e', - MapsTo y e' (add x e m) <-> - (E.eq x y /\ e=e') \/ +Lemma add_mapsto_iff : forall m x y e e', + MapsTo y e' (add x e m) <-> + (E.eq x y /\ e=e') \/ (~E.eq x y /\ MapsTo y e' m). -Proof. +Proof. intros. intuition. destruct (eq_dec x y); [left|right]. @@ -147,7 +144,7 @@ subst; auto with map. Qed. Lemma add_in_iff : forall m x y e, In y (add x e m) <-> E.eq x y \/ In y m. -Proof. +Proof. unfold In; split. intros (e',H). destruct (eq_dec x y) as [E|E]; auto. @@ -161,13 +158,13 @@ destruct E; auto. exists e'; apply add_2; auto. Qed. -Lemma add_neq_mapsto_iff : forall m x y e e', +Lemma add_neq_mapsto_iff : forall m x y e e', ~ E.eq x y -> (MapsTo y e' (add x e m) <-> MapsTo y e' m). Proof. split; [apply add_3|apply add_2]; auto. Qed. -Lemma add_neq_in_iff : forall m x y e, +Lemma add_neq_in_iff : forall m x y e, ~ E.eq x y -> (In y (add x e m) <-> In y m). Proof. split; intros (e',H0); exists e'. @@ -175,9 +172,9 @@ apply (add_3 H H0). apply add_2; auto. Qed. -Lemma remove_mapsto_iff : forall m x y e, +Lemma remove_mapsto_iff : forall m x y e, MapsTo y e (remove x m) <-> ~E.eq x y /\ MapsTo y e m. -Proof. +Proof. intros. split; intros. split. @@ -188,7 +185,7 @@ apply remove_2; intuition. Qed. Lemma remove_in_iff : forall m x y, In y (remove x m) <-> ~E.eq x y /\ In y m. -Proof. +Proof. unfold In; split. intros (e,H). split. @@ -198,13 +195,13 @@ exists e; apply remove_3 with x; auto. intros (H,(e,H0)); exists e; apply remove_2; auto. Qed. -Lemma remove_neq_mapsto_iff : forall m x y e, +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, +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'. @@ -212,19 +209,19 @@ apply (remove_3 H0). apply remove_2; auto. Qed. -Lemma elements_mapsto_iff : forall m x e, +Lemma elements_mapsto_iff : forall m x e, MapsTo x e m <-> InA (@eq_key_elt _) (x,e) (elements m). -Proof. +Proof. split; [apply elements_1 | apply elements_2]. Qed. -Lemma elements_in_iff : forall m x, +Lemma elements_in_iff : forall m x, In x m <-> exists e, InA (@eq_key_elt _) (x,e) (elements m). -Proof. +Proof. unfold In; split; intros (e,H); exists e; [apply elements_1 | apply elements_2]; auto. Qed. -Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), +Lemma map_mapsto_iff : forall m x b (f : elt -> elt'), MapsTo x b (map f m) <-> exists a, b = f a /\ MapsTo x a m. Proof. split. @@ -240,7 +237,7 @@ intros (a,(H,H0)). subst b; auto with map. Qed. -Lemma map_in_iff : forall m x (f : elt -> elt'), +Lemma map_in_iff : forall m x (f : elt -> elt'), In x (map f m) <-> In x m. Proof. split; intros; eauto with map. @@ -257,11 +254,11 @@ destruct (mapi_1 f H) as (y,(H0,H1)). exists (f y a); auto. Qed. -(** Unfortunately, we don't have simple equivalences for [mapi] - and [MapsTo]. The only correct one needs compatibility of [f]. *) +(** Unfortunately, we don't have simple equivalences for [mapi] + and [MapsTo]. The only correct one needs compatibility of [f]. *) -Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), - MapsTo x b (mapi f m) -> +Lemma mapi_inv : forall m x b (f : key -> elt -> elt'), + MapsTo x b (mapi f m) -> exists a, exists y, E.eq y x /\ b = f y a /\ MapsTo x a m. Proof. intros; case_eq (find x m); intros. @@ -275,8 +272,8 @@ destruct (mapi_2 H1) as (a,H2). rewrite (find_1 H2) in H0; discriminate. Qed. -Lemma mapi_1bis : forall m x e (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> +Lemma mapi_1bis : forall m x e (f:key->elt->elt'), + (forall x y e, E.eq x y -> f x e = f y e) -> MapsTo x e m -> MapsTo x (f x e) (mapi f m). Proof. intros. @@ -286,7 +283,7 @@ auto. Qed. Lemma mapi_mapsto_iff : forall m x b (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> + (forall x y e, E.eq x y -> f x e = f y e) -> (MapsTo x b (mapi f m) <-> exists a, b = f x a /\ MapsTo x a m). Proof. split. @@ -299,14 +296,14 @@ subst b. apply mapi_1bis; auto. Qed. -(** Things are even worse for [map2] : we don't try to state any +(** Things are even worse for [map2] : we don't try to state any equivalence, see instead boolean results below. *) End IffSpec. (** Useful tactic for simplifying expressions like [In y (add x e (remove z m))] *) - -Ltac map_iff := + +Ltac map_iff := repeat (progress ( rewrite add_mapsto_iff || rewrite add_in_iff || rewrite remove_mapsto_iff || rewrite remove_in_iff || @@ -318,7 +315,7 @@ Ltac map_iff := Section BoolSpec. -Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false. +Lemma mem_find_b : forall (elt:Type)(m:t elt)(x:key), mem x m = if find x m then true else false. Proof. intros. generalize (find_mapsto_iff m x)(mem_in_iff m x); unfold In. @@ -336,7 +333,7 @@ Implicit Types x y z : key. Implicit Types e : elt. Lemma mem_b : forall m x y, E.eq x y -> mem x m = mem y m. -Proof. +Proof. intros. generalize (mem_in_iff m x) (mem_in_iff m y)(In_iff m H). destruct (mem x m); destruct (mem y m); intuition. @@ -362,14 +359,14 @@ generalize (mem_2 H). rewrite empty_in_iff; intuition. Qed. -Lemma add_eq_o : forall m x y e, +Lemma add_eq_o : forall m x y e, E.eq x y -> find y (add x e m) = Some e. Proof. auto with map. Qed. -Lemma add_neq_o : forall m x y e, - ~ E.eq x y -> find y (add x e m) = find y m. +Lemma add_neq_o : forall m x y e, + ~ E.eq x y -> find y (add x e m) = find y m. Proof. intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. apply add_neq_mapsto_iff; auto. @@ -382,26 +379,26 @@ Proof. intros; destruct (eq_dec x y); auto with map. Qed. -Lemma add_eq_b : forall m x y e, +Lemma add_eq_b : forall m x y e, E.eq x y -> mem y (add x e m) = true. Proof. intros; rewrite mem_find_b; rewrite add_eq_o; auto. Qed. -Lemma add_neq_b : forall m x y e, +Lemma add_neq_b : forall m x y e, ~E.eq x y -> mem y (add x e m) = mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite add_neq_o; auto. Qed. -Lemma add_b : forall m x y e, - mem y (add x e m) = eqb x y || mem y m. +Lemma add_b : forall m x y e, + mem y (add x e m) = eqb x y || mem y m. Proof. intros; do 2 rewrite mem_find_b; rewrite add_o; unfold eqb. destruct (eq_dec x y); simpl; auto. Qed. -Lemma remove_eq_o : forall m x y, +Lemma remove_eq_o : forall m x y, E.eq x y -> find y (remove x m) = None. Proof. intros. rewrite eq_option_alt. intro e. @@ -442,14 +439,14 @@ intros; do 2 rewrite mem_find_b; rewrite remove_o; unfold eqb. destruct (eq_dec x y); auto. Qed. -Definition option_map (A B:Type)(f:A->B)(o:option A) : option B := - match o with +Definition option_map (A B:Type)(f:A->B)(o:option A) : option B := + match o with | Some a => Some (f a) | None => None end. -Lemma map_o : forall m x (f:elt->elt'), - find x (map f m) = option_map f (find x m). +Lemma map_o : forall m x (f:elt->elt'), + find x (map f m) = option_map f (find x m). Proof. intros. generalize (find_mapsto_iff (map f m) x) (find_mapsto_iff m x) @@ -463,14 +460,14 @@ rewrite H0 in H2; discriminate. rewrite <- H; rewrite H1; exists e; rewrite H0; auto. Qed. -Lemma map_b : forall m x (f:elt->elt'), +Lemma map_b : forall m x (f:elt->elt'), mem x (map f m) = mem x m. Proof. intros; do 2 rewrite mem_find_b; rewrite map_o. destruct (find x m); simpl; auto. Qed. -Lemma mapi_b : forall m x (f:key->elt->elt'), +Lemma mapi_b : forall m x (f:key->elt->elt'), mem x (mapi f m) = mem x m. Proof. intros. @@ -480,12 +477,12 @@ symmetry; rewrite <- H0; rewrite <- H1; rewrite H; auto. rewrite <- H; rewrite H1; rewrite H0; auto. Qed. -Lemma mapi_o : forall m x (f:key->elt->elt'), - (forall x y e, E.eq x y -> f x e = f y e) -> +Lemma mapi_o : forall m x (f:key->elt->elt'), + (forall x y e, E.eq x y -> f x e = f y e) -> find x (mapi f m) = option_map (f x) (find x m). Proof. intros. -generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) +generalize (find_mapsto_iff (mapi f m) x) (find_mapsto_iff m x) (fun b => mapi_mapsto_iff m x b H). destruct (find x (mapi f m)); destruct (find x m); simpl; auto; intros. rewrite <- H0; rewrite H2; exists e0; rewrite H1; auto. @@ -496,9 +493,9 @@ rewrite H1 in H3; discriminate. rewrite <- H0; rewrite H2; exists e; rewrite H1; auto. Qed. -Lemma map2_1bis : forall (m: t elt)(m': t elt') x - (f:option elt->option elt'->option elt''), - f None None = None -> +Lemma map2_1bis : forall (m: t elt)(m': t elt') x + (f:option elt->option elt'->option elt''), + f None None = None -> find x (map2 f m m') = f (find x m) (find x m'). Proof. intros. @@ -574,7 +571,7 @@ Qed. (** First, [Equal] is [Equiv] with Leibniz on elements. *) Lemma Equal_Equiv : forall (m m' : t elt), - Equal m m' <-> Equiv (@Logic.eq elt) m m'. + Equal m m' <-> Equiv Logic.eq m m'. Proof. intros. rewrite Equal_mapsto_iff. split; intros. split. @@ -598,7 +595,7 @@ Section Cmp. Variable eq_elt : elt->elt->Prop. Variable cmp : elt->elt->bool. -Definition compat_cmp := +Definition compat_cmp := forall e e', cmp e e' = true <-> eq_elt e e'. Lemma Equiv_Equivb : compat_cmp -> @@ -613,17 +610,17 @@ 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') -> +Lemma Equal_Equivb : forall cmp, + (forall e e', cmp e e' = true <-> e = e') -> forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. Proof. intros; rewrite Equal_Equiv. apply Equiv_Equivb; auto. Qed. -Lemma Equal_Equivb_eqdec : +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 + let cmp := fun e e' => if eq_elt_dec e e' then true else false in forall (m m':t elt), Equal m m' <-> Equivb cmp m m'. Proof. intros; apply Equal_Equivb. @@ -638,11 +635,11 @@ End Equalities. Lemma Equal_refl : forall (elt:Type)(m : t elt), Equal m m. Proof. red; reflexivity. Qed. -Lemma Equal_sym : forall (elt:Type)(m m' : t elt), +Lemma Equal_sym : forall (elt:Type)(m m' : t elt), Equal m m' -> Equal m' m. Proof. unfold Equal; auto. Qed. -Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), +Lemma Equal_trans : forall (elt:Type)(m m' m'' : t elt), Equal m m' -> Equal m' m'' -> Equal m m''. Proof. unfold Equal; congruence. Qed. @@ -651,15 +648,15 @@ Proof. constructor; red; [apply Equal_refl | apply Equal_sym | apply Equal_trans]. Qed. -Add Relation key E.eq - reflexivity proved by E.eq_refl +Add Relation key E.eq + reflexivity proved by E.eq_refl symmetry proved by E.eq_sym - transitivity proved by E.eq_trans + transitivity proved by E.eq_trans as KeySetoid. Implicit Arguments Equal [[elt]]. -Add Parametric Relation (elt : Type) : (t elt) Equal +Add Parametric Relation (elt : Type) : (t elt) Equal reflexivity proved by (@Equal_refl elt) symmetry proved by (@Equal_sym elt) transitivity proved by (@Equal_trans elt) @@ -673,7 +670,7 @@ rewrite (In_iff m Hk), in_find_iff, in_find_iff, Hm; intuition. Qed. Add Parametric Morphism elt : (@MapsTo elt) - with signature E.eq ==> Leibniz ==> Equal ==> iff as MapsTo_m. + with signature E.eq ==> eq ==> Equal ==> iff as MapsTo_m. Proof. unfold Equal; intros k k' Hk e m m' Hm. rewrite (MapsTo_iff m e Hk), find_mapsto_iff, find_mapsto_iff, Hm; @@ -689,28 +686,28 @@ rewrite Hm in H0; eauto. Qed. Add Parametric Morphism elt : (@is_empty elt) - with signature Equal ==> Leibniz as is_empty_m. + with signature Equal ==> eq as is_empty_m. Proof. intros m m' Hm. rewrite eq_bool_alt, <-is_empty_iff, <-is_empty_iff, Hm; intuition. Qed. Add Parametric Morphism elt : (@mem elt) - with signature E.eq ==> Equal ==> Leibniz as mem_m. + with signature E.eq ==> Equal ==> eq as mem_m. Proof. intros k k' Hk m m' Hm. rewrite eq_bool_alt, <- mem_in_iff, <-mem_in_iff, Hk, Hm; intuition. Qed. Add Parametric Morphism elt : (@find elt) - with signature E.eq ==> Equal ==> Leibniz as find_m. + with signature E.eq ==> Equal ==> eq as find_m. Proof. intros k k' Hk m m' Hm. rewrite eq_option_alt. intro e. rewrite <- 2 find_mapsto_iff, Hk, Hm. split; auto. Qed. Add Parametric Morphism elt : (@add elt) - with signature E.eq ==> Leibniz ==> Equal ==> Equal as add_m. + with signature E.eq ==> eq ==> Equal ==> Equal as add_m. Proof. intros k k' Hk e m m' Hm y. rewrite add_o, add_o; do 2 destruct eq_dec; auto. @@ -728,7 +725,7 @@ elim n; rewrite Hk; auto. Qed. Add Parametric Morphism elt elt' : (@map elt elt') - with signature Leibniz ==> Equal ==> Equal as map_m. + with signature eq ==> Equal ==> Equal as map_m. Proof. intros f m m' Hm y. rewrite map_o, map_o, Hm; auto. @@ -763,6 +760,16 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Notation eqke := (@eq_key_elt elt). Notation eqk := (@eq_key elt). + Instance eqk_equiv : Equivalence eqk. + Proof. split; repeat red; eauto. Qed. + + Instance eqke_equiv : Equivalence eqke. + Proof. + unfold eq_key_elt; split; repeat red; firstorder. + eauto with *. + congruence. + Qed. + (** Complements about InA, NoDupA and findA *) Lemma InA_eqke_eqk : forall k1 k2 e1 e2 l, @@ -790,12 +797,12 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). intros. symmetry. unfold eqb. rewrite <- findA_NoDupA, InA_rev, findA_NoDupA - by eauto using NoDupA_rev; eauto. + by (eauto using NoDupA_rev with *); eauto. case_eq (findA (eqb k) (rev l)); auto. intros e. unfold eqb. rewrite <- findA_NoDupA, InA_rev, findA_NoDupA - by eauto using NoDupA_rev. + by (eauto using NoDupA_rev with *). intro Eq; rewrite Eq; auto. Qed. @@ -896,9 +903,10 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). assert (Hstep' : forall k e a m' m'', InA eqke (k,e) l -> ~In k m' -> Add k e m' m'' -> P m' a -> P m'' (F (k,e) a)). intros k e a m' m'' H ? ? ?; eapply Hstep; eauto. - revert H; unfold l; rewrite InA_rev, elements_mapsto_iff; auto. + revert H; unfold l; rewrite InA_rev, elements_mapsto_iff; auto with *. assert (Hdup : NoDupA eqk l). - unfold l. apply NoDupA_rev; try red; eauto. apply elements_3w. + unfold l. apply NoDupA_rev; try red; unfold eq_key ; eauto with *. + apply elements_3w. assert (Hsame : forall k, find k m = findA (eqb k) l). intros k. unfold l. rewrite elements_o, findA_rev; auto. apply elements_3w. @@ -979,7 +987,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). set (l:=rev (elements m)). assert (Rstep' : forall k e a b, InA eqke (k,e) l -> R a b -> R (f k e a) (g k e b)) by - (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; auto). + (intros; apply Rstep; auto; rewrite elements_mapsto_iff, <- InA_rev; auto with *). clearbody l; clear Rstep m. induction l; simpl; auto. apply Rstep'; auto. @@ -1020,7 +1028,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). 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'. - rewrite Hadd, 2 add_o, Heq; auto. + red in Heq. rewrite Hadd, 2 add_o, Heq; auto. Qed. Section Fold_More. @@ -1034,8 +1042,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). (** This is more convenient than a [compat_op eqke ...]. In fact, every [compat_op], [compat_bool], etc, should - become a [Morphism] someday. *) - Hypothesis Comp : Morphism (E.eq==>Leibniz==>eqA==>eqA) f. + become a [Proper] someday. *) + Hypothesis Comp : Proper (E.eq==>eq==>eqA==>eqA) f. Lemma fold_init : forall m i i', eqA i i' -> eqA (fold f m i) (fold f m i'). @@ -1086,77 +1094,53 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). contradict Hnotin; rewrite <- Hnotin; exists e0; auto. Qed. + Hint Resolve NoDupA_eqk_eqke NoDupA_rev elements_3w : map. + Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 -> eqA (fold f m1 i) (fold f m2 i). Proof. - assert (eqke_refl : forall p, eqke p p). - red; auto. - assert (eqke_sym : forall p p', eqke p p' -> eqke p' p). - intros (x1,x2) (y1,y2); unfold eq_key_elt; simpl; intuition. - assert (eqke_trans : forall p p' p'', eqke p p' -> eqke p' p'' -> eqke p p''). - intros (x1,x2) (y1,y2) (z1,z2); unfold eq_key_elt; simpl. - intuition; eauto; congruence. intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. - apply fold_right_equivlistA_restr with - (R:=fun p p' => ~eqk p p') (eqA:=eqke) (eqB:=eqA); auto. - intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; simpl in *; apply Comp; auto. - unfold eq_key; auto. - intros (k1,e1) (k2,e2) (k3,e3). unfold eq_key_elt, eq_key; simpl. - intuition eauto. + assert (NoDupA eqk (rev (elements m1))) by (auto with *). + assert (NoDupA eqk (rev (elements m2))) by (auto with *). + apply fold_right_equivlistA_restr with (R:=complement eqk)(eqA:=eqke); + auto with *. + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; simpl in *; apply Comp; auto. + unfold complement, eq_key, eq_key_elt; repeat red. intuition eauto. intros (k,e) (k',e'); unfold eq_key; simpl; auto. - apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. - apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. - apply ForallList2_equiv1 with (eqA:=eqk); try red; eauto. - apply NoDupA_rev; try red; eauto. apply elements_3w. - red; intros. - do 2 rewrite InA_rev. - destruct x; do 2 rewrite <- elements_mapsto_iff. - do 2 rewrite find_mapsto_iff. - rewrite H; split; auto. + rewrite <- NoDupA_altdef; auto. + intros (k,e). + rewrite 2 InA_rev, <- 2 elements_mapsto_iff, 2 find_mapsto_iff, H; + auto with *. Qed. Lemma fold_Add : forall m1 m2 k e i, ~In k m1 -> Add k e m1 m2 -> eqA (fold f m2 i) (f k e (fold f m1 i)). Proof. - assert (eqke_refl : forall p, eqke p p). - red; auto. - assert (eqke_sym : forall p p', eqke p p' -> eqke p' p). - intros (x1,x2) (y1,y2); unfold eq_key_elt; simpl; intuition. - assert (eqke_trans : forall p p' p'', eqke p p' -> eqke p' p'' -> eqke p p''). - intros (x1,x2) (y1,y2) (z1,z2); unfold eq_key_elt; simpl. - intuition; eauto; congruence. intros; do 2 rewrite fold_1; do 2 rewrite <- fold_left_rev_right. set (f':=fun y x0 => f (fst y) (snd y) x0) in *. change (f k e (fold_right f' i (rev (elements m1)))) with (f' (k,e) (fold_right f' i (rev (elements m1)))). + assert (NoDupA eqk (rev (elements m1))) by (auto with *). + assert (NoDupA eqk (rev (elements m2))) by (auto with *). apply fold_right_add_restr with - (R:=fun p p'=>~eqk p p')(eqA:=eqke)(eqB:=eqA); auto. - intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *. apply Comp; auto. - - unfold eq_key; auto. - intros (k1,e1) (k2,e2) (k3,e3). unfold eq_key_elt, eq_key; simpl. - intuition eauto. + (R:=complement eqk)(eqA:=eqke)(eqB:=eqA); auto with *. + intros (k1,e1) (k2,e2) (Hk,He) a a' Ha; unfold f'; simpl in *. apply Comp; auto. + unfold complement, eq_key_elt, eq_key; repeat red; intuition eauto. unfold f'; intros (k1,e1) (k2,e2); unfold eq_key; simpl; auto. - apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. - apply NoDupA_rev; auto; apply NoDupA_eqk_eqke; apply elements_3w. - apply ForallList2_equiv1 with (eqA:=eqk); try red; eauto. - apply NoDupA_rev; try red; eauto. apply elements_3w. - rewrite InA_rev. - contradict H. - exists e. - rewrite elements_mapsto_iff; auto. - intros a. - rewrite InA_cons; do 2 rewrite InA_rev; - destruct a as (a,b); do 2 rewrite <- elements_mapsto_iff. - do 2 rewrite find_mapsto_iff; unfold eq_key_elt; simpl. + rewrite <- NoDupA_altdef; auto. + rewrite InA_rev, <- elements_mapsto_iff by (auto with *). firstorder. + intros (a,b). + rewrite InA_cons, 2 InA_rev, <- 2 elements_mapsto_iff, + 2 find_mapsto_iff by (auto with *). + unfold eq_key_elt; simpl. rewrite H0. rewrite add_o. - destruct (eq_dec k a); intuition. - inversion H1; auto. - f_equal; auto. - elim H. - exists b; apply MapsTo_1 with a; auto with map. - elim n; auto. + destruct (eq_dec k a) as [EQ|NEQ]; split; auto. + intros EQ'; inversion EQ'; auto. + intuition; subst; auto. + elim H. exists b; rewrite EQ; auto with map. + intuition. + elim NEQ; auto. Qed. Lemma fold_add : forall m k e i, ~In k m -> @@ -1188,7 +1172,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Equal m m' -> cardinal m = cardinal m'. Proof. intros; do 2 rewrite cardinal_fold. - apply fold_Equal with (eqA:=Leibniz); compute; auto. + apply fold_Equal with (eqA:=eq); compute; auto. Qed. Lemma cardinal_1 : forall m : t elt, Empty m -> cardinal m = 0. @@ -1201,22 +1185,22 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Proof. intros; do 2 rewrite cardinal_fold. change S with ((fun _ _ => S) x e). - apply fold_Add with (eqA:=Leibniz); compute; auto. + apply fold_Add with (eqA:=eq); compute; auto. Qed. - Lemma cardinal_inv_1 : forall m : t elt, + Lemma cardinal_inv_1 : forall m : t elt, cardinal m = 0 -> Empty m. Proof. - intros; rewrite cardinal_Empty; auto. + 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. + Proof. intros; rewrite M.cardinal_1 in *. generalize (elements_mapsto_iff m). - destruct (elements m); try discriminate. + destruct (elements m); try discriminate. exists p; auto. rewrite H0; destruct p; simpl; auto. constructor; red; auto. @@ -1242,16 +1226,16 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). (** * Emulation of some functions lacking in the interface *) - Definition filter (f : key -> elt -> bool)(m : t elt) := + 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) := + 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) := + 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) := + 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 @@ -1272,7 +1256,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Section Specs. Variable f : key -> elt -> bool. - Hypothesis Hf : Morphism (E.eq==>Leibniz==>Leibniz) f. + Hypothesis Hf : Proper (E.eq==>eq==>eq) f. Lemma filter_iff : forall m k e, MapsTo k e (filter f m) <-> MapsTo k e m /\ f k e = true. @@ -1315,8 +1299,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). apply Hmapsto. rewrite Hadd, add_mapsto_iff; right; split; auto. contradict Hn; exists e'; rewrite Hn; auto. (* f k e = false *) - split; intros H; try discriminate. - rewrite <- Hfke. apply H. + split; try discriminate. + intros Hmapsto. rewrite <- Hfke. apply Hmapsto. rewrite Hadd, add_mapsto_iff; auto. Qed. @@ -1328,7 +1312,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). set (f':=fun k e b => if f k e then true else b). intro m. pattern m, (fold f' m false). apply fold_rec. - intros m' Hm'. split; try (intros; discriminate). + intros m' Hm'. split; try discriminate. intros ((k,e),(Hke,_)); simpl in *. elim (Hm' k e); auto. intros k e b m1 m2 _ Hn Hadd IH. clear m. @@ -1365,7 +1349,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Section Partition. Variable f : key -> elt -> bool. - Hypothesis Hf : Morphism (E.eq==>Leibniz==>Leibniz) f. + Hypothesis Hf : Proper (E.eq==>eq==>eq) f. Lemma partition_iff_1 : forall m m1 k e, m1 = fst (partition f m) -> @@ -1494,7 +1478,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Lemma Partition_fold : forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)(f:key->elt->A->A), - Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + Proper (E.eq==>eq==>eqA==>eqA) f -> transpose_neqkey eqA f -> forall m m1 m2 i, Partition m m1 m2 -> @@ -1547,9 +1531,8 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). set (f:=fun (_:key)(_:elt)=>S). setoid_replace (fold f m 0) with (fold f m1 (fold f m2 0)). rewrite <- cardinal_fold. - intros. apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. - apply Partition_fold with (eqA:=@Logic.eq _); try red; auto. - compute; auto. + apply fold_rel with (R:=fun u v => u = v + cardinal m2); simpl; auto. + apply Partition_fold with (eqA:=eq); repeat red; auto. Qed. Lemma Partition_partition : forall m m1 m2, Partition m m1 m2 -> @@ -1557,7 +1540,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Equal m1 (fst (partition f m)) /\ Equal m2 (snd (partition f m)). Proof. intros m m1 m2 Hm f. - assert (Hf : Morphism (E.eq==>Leibniz==>Leibniz) 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)). @@ -1673,7 +1656,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). End Elt. Add Parametric Morphism elt : (@cardinal elt) - with signature Equal ==> Leibniz as cardinal_m. + with signature Equal ==> eq as cardinal_m. Proof. intros; apply Equal_cardinal; auto. Qed. Add Parametric Morphism elt : (@Disjoint elt) @@ -1761,7 +1744,7 @@ Module OrdProperties (M:S). Import F. Import M. - Section Elt. + Section Elt. Variable elt:Type. Notation eqke := (@eqke elt). @@ -1779,15 +1762,14 @@ Module OrdProperties (M:S). 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; - unfold O.eqke, O.ltk; simpl; intuition; eauto. + apply SortA_equivlistA_eqlistA; eauto with *. Qed. Ltac clean_eauto := unfold O.eqke, O.ltk; simpl; intuition; eauto. Definition gtb (p p':key*elt) := match E.compare (fst p) (fst p') with GT _ => true | _ => false end. - Definition leb p := fun p' => negb (gtb p p'). + Definition leb p := fun p' => negb (gtb p p'). Definition elements_lt p m := List.filter (gtb p) (elements m). Definition elements_ge p m := List.filter (leb p) (elements m). @@ -1804,10 +1786,10 @@ Module OrdProperties (M:S). destruct (E.compare x y); intuition; try discriminate; ME.order. Qed. - Lemma gtb_compat : forall p, compat_bool eqke (gtb p). + Lemma gtb_compat : forall p, Proper (eqke==>eq) (gtb p). Proof. red; intros (x,e) (a,e') (b,e'') H; red in H; simpl in *; destruct H. - generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); + generalize (gtb_1 (x,e) (a,e'))(gtb_1 (x,e) (b,e'')); destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto. unfold O.ltk in *; simpl in *; intros. symmetry; rewrite H2. @@ -1819,7 +1801,7 @@ Module OrdProperties (M:S). rewrite <- H2; auto. Qed. - Lemma leb_compat : forall p, compat_bool eqke (leb p). + Lemma leb_compat : forall p, Proper (eqke==>eq) (leb p). Proof. red; intros x a b H. unfold leb; f_equal; apply gtb_compat; auto. @@ -1827,11 +1809,11 @@ Module OrdProperties (M:S). Hint Resolve gtb_compat leb_compat elements_3 : map. - Lemma elements_split : forall p m, + Lemma elements_split : forall p m, elements m = elements_lt p m ++ elements_ge p m. Proof. unfold elements_lt, elements_ge, leb; intros. - apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with map. + apply filter_split with (eqA:=eqk) (ltA:=ltk); eauto with *. intros; destruct x; destruct y; destruct p. rewrite gtb_1 in H; unfold O.ltk in H; simpl in *. assert (~ltk (t1,e0) (k,e1)). @@ -1840,19 +1822,19 @@ Module OrdProperties (M:S). unfold O.ltk in *; simpl in *; ME.order. Qed. - Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> - eqlistA eqke (elements m') + Lemma elements_Add : forall m m' x e, ~In x m -> Add x e m m' -> + eqlistA eqke (elements m') (elements_lt (x,e) m ++ (x,e):: elements_ge (x,e) m). Proof. intros; unfold elements_lt, elements_ge. - apply sort_equivlistA_eqlistA; auto with map. - apply (@SortA_app _ eqke); auto with map. - apply (@filter_sort _ eqke); auto with map; clean_eauto. + apply sort_equivlistA_eqlistA; auto with *. + apply (@SortA_app _ eqke); auto with *. + apply (@filter_sort _ eqke); auto with *; clean_eauto. constructor; auto with map. - apply (@filter_sort _ eqke); auto with map; clean_eauto. - rewrite (@InfA_alt _ eqke); auto with map; try (clean_eauto; fail). + apply (@filter_sort _ eqke); auto with *; clean_eauto. + rewrite (@InfA_alt _ eqke); auto with *; try (clean_eauto; fail). intros. - rewrite filter_InA in H1; auto with map; destruct H1. + rewrite filter_InA in H1; auto with *; destruct H1. rewrite leb_1 in H2. destruct y; unfold O.ltk in *; simpl in *. rewrite <- elements_mapsto_iff in H1. @@ -1860,24 +1842,22 @@ Module OrdProperties (M:S). contradict H. exists e0; apply MapsTo_1 with t0; auto. ME.order. - apply (@filter_sort _ eqke); auto with map; clean_eauto. + apply (@filter_sort _ eqke); auto with *; clean_eauto. intros. - rewrite filter_InA in H1; auto with map; destruct H1. + rewrite filter_InA in H1; auto with *; destruct H1. rewrite gtb_1 in H3. destruct y; destruct x0; unfold O.ltk in *; simpl in *. inversion_clear H2. red in H4; simpl in *; destruct H4. ME.order. - rewrite filter_InA in H4; auto with map; destruct H4. + rewrite filter_InA in H4; auto with *; destruct H4. rewrite leb_1 in H4. unfold O.ltk in *; simpl in *; ME.order. red; intros a; destruct a. - rewrite InA_app_iff; rewrite InA_cons. - do 2 (rewrite filter_InA; auto with map). - do 2 rewrite <- elements_mapsto_iff. - rewrite leb_1; rewrite gtb_1. - rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. - rewrite add_mapsto_iff. + rewrite InA_app_iff, InA_cons, 2 filter_InA, + <-2 elements_mapsto_iff, leb_1, gtb_1, + find_mapsto_iff, (H0 t0), <- find_mapsto_iff, + add_mapsto_iff by (auto with *). unfold O.eqke, O.ltk; simpl. destruct (E.compare t0 x); intuition. right; split; auto; ME.order. @@ -1889,13 +1869,13 @@ Module OrdProperties (M:S). right; split; auto; ME.order. Qed. - Lemma elements_Add_Above : forall m m' x e, - Above x m -> Add x e m m' -> + Lemma elements_Add_Above : forall m m' x e, + Above x m -> Add x e m m' -> eqlistA eqke (elements m') (elements m ++ (x,e)::nil). Proof. intros. - apply sort_equivlistA_eqlistA; auto with map. - apply (@SortA_app _ eqke); auto with map. + apply sort_equivlistA_eqlistA; auto with *. + apply (@SortA_app _ eqke); auto with *. intros. inversion_clear H2. destruct x0; destruct y. @@ -1905,27 +1885,26 @@ Module OrdProperties (M:S). apply H; firstorder. inversion H3. red; intros a; destruct a. - rewrite InA_app_iff; rewrite InA_cons; rewrite InA_nil. - do 2 rewrite <- elements_mapsto_iff. - rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. - rewrite add_mapsto_iff; unfold O.eqke; simpl. - intuition. + rewrite InA_app_iff, InA_cons, InA_nil, <- 2 elements_mapsto_iff, + find_mapsto_iff, (H0 t0), <- find_mapsto_iff, + add_mapsto_iff by (auto with *). + unfold O.eqke; simpl. intuition. destruct (E.eq_dec x t0); auto. - elimtype False. + exfalso. assert (In t0 m). exists e0; auto. generalize (H t0 H1). ME.order. Qed. - Lemma elements_Add_Below : forall m m' x e, - Below x m -> Add x e m m' -> + Lemma elements_Add_Below : forall m m' x e, + Below x m -> Add x e m m' -> eqlistA eqke (elements m') ((x,e)::elements m). Proof. intros. - apply sort_equivlistA_eqlistA; auto with map. + apply sort_equivlistA_eqlistA; auto with *. change (sort ltk (((x,e)::nil) ++ elements m)). - apply (@SortA_app _ eqke); auto with map. + apply (@SortA_app _ eqke); auto with *. intros. inversion_clear H1. destruct y; destruct x0. @@ -1935,24 +1914,23 @@ Module OrdProperties (M:S). apply H; firstorder. inversion H3. red; intros a; destruct a. - rewrite InA_cons. - do 2 rewrite <- elements_mapsto_iff. - rewrite find_mapsto_iff; rewrite (H0 t0); rewrite <- find_mapsto_iff. - rewrite add_mapsto_iff; unfold O.eqke; simpl. - intuition. + rewrite InA_cons, <- 2 elements_mapsto_iff, + find_mapsto_iff, (H0 t0), <- find_mapsto_iff, + add_mapsto_iff by (auto with *). + unfold O.eqke; simpl. intuition. destruct (E.eq_dec x t0); auto. - elimtype False. + exfalso. assert (In t0 m). exists e0; auto. generalize (H t0 H1). ME.order. Qed. - Lemma elements_Equal_eqlistA : forall (m m': t elt), + Lemma elements_Equal_eqlistA : forall (m m': t elt), Equal m m' -> eqlistA eqke (elements m) (elements m'). Proof. intros. - apply sort_equivlistA_eqlistA; auto with map. + apply sort_equivlistA_eqlistA; auto with *. red; intros. destruct x; do 2 rewrite <- elements_mapsto_iff. do 2 rewrite find_mapsto_iff; rewrite H; split; auto. @@ -1963,15 +1941,15 @@ Module OrdProperties (M:S). 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 + + Fixpoint max_elt_aux (l:list (key*elt)) := match l with + | nil => None | (x,e)::nil => Some (x,e) | (x,e)::l => max_elt_aux l end. Definition max_elt m := max_elt_aux (elements m). - Lemma max_elt_Above : + Lemma max_elt_Above : forall m x e, max_elt m = Some (x,e) -> Above x (remove x m). Proof. red; intros. @@ -2010,8 +1988,8 @@ Module OrdProperties (M:S). red; eauto. inversion H2; auto. Qed. - - Lemma max_elt_MapsTo : + + Lemma max_elt_MapsTo : forall m x e, max_elt m = Some (x,e) -> MapsTo x e m. Proof. intros. @@ -2024,7 +2002,7 @@ Module OrdProperties (M:S). constructor 2; auto. Qed. - Lemma max_elt_Empty : + Lemma max_elt_Empty : forall m, max_elt m = None -> Empty m. Proof. intros. @@ -2035,12 +2013,12 @@ Module OrdProperties (M:S). assert (H':=IHl H); discriminate. Qed. - Definition min_elt m : option (key*elt) := match elements m with + Definition min_elt m : option (key*elt) := match elements m with | nil => None | (x,e)::_ => Some (x,e) end. - Lemma min_elt_Below : + 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. @@ -2054,14 +2032,11 @@ Module OrdProperties (M:S). inversion_clear H1. red in H2; destruct H2; simpl in *; ME.order. inversion_clear H4. - rewrite (@InfA_alt _ eqke) in H3; eauto. + rewrite (@InfA_alt _ eqke) in H3; eauto with *. apply (H3 (y,x0)); auto. - unfold lt_key; simpl; intuition; eauto. - intros (x1,x2) (y1,y2) (z1,z2); compute; intuition; eauto. - intros (x1,x2) (y1,y2) (z1,z2); compute; intuition; eauto. Qed. - - Lemma min_elt_MapsTo : + + Lemma min_elt_MapsTo : forall m x e, min_elt m = Some (x,e) -> MapsTo x e m. Proof. intros. @@ -2073,7 +2048,7 @@ Module OrdProperties (M:S). injection H; intros; subst; constructor; red; auto. Qed. - Lemma min_elt_Empty : + Lemma min_elt_Empty : forall m, min_elt m = None -> Empty m. Proof. intros. @@ -2108,7 +2083,7 @@ Module OrdProperties (M:S). assert (S n = S (cardinal (remove k m))). rewrite Heqn. eapply cardinal_2; eauto with map. - inversion H1; auto. + inversion H1; auto. eapply max_elt_Above; eauto. apply X; apply max_elt_Empty; auto. @@ -2135,7 +2110,7 @@ Module OrdProperties (M:S). assert (S n = S (cardinal (remove k m))). rewrite Heqn. eapply cardinal_2; eauto with map. - inversion H1; auto. + inversion H1; auto. eapply min_elt_Below; eauto. apply X; apply min_elt_Empty; auto. @@ -2150,7 +2125,7 @@ Module OrdProperties (M:S). Lemma fold_Equal : forall m1 m2 (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f:key->elt->A->A)(i:A), - Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + Proper (E.eq==>eq==>eqA==>eqA) f -> Equal m1 m2 -> eqA (fold f m1 i) (fold f m2 i). Proof. @@ -2158,13 +2133,12 @@ Module OrdProperties (M:S). do 2 rewrite fold_1. do 2 rewrite <- fold_left_rev_right. apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k,e) (k',e') a a' (Hk,He) Ha; simpl in *; apply Hf; auto. + intros (k,e) (k',e') (Hk,He) a a' Ha; simpl in *; apply Hf; auto. apply eqlistA_rev. apply elements_Equal_eqlistA. auto. Qed. Lemma fold_Add_Above : forall m1 m2 x e (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) - (f:key->elt->A->A)(i:A), - Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + (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. @@ -2172,7 +2146,7 @@ Module OrdProperties (M:S). set (f':=fun y x0 => f (fst y) (snd y) x0) in *. transitivity (fold_right f' i (rev (elements m1 ++ (x,e)::nil))). apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *; apply H; auto. + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *. apply P; auto. apply eqlistA_rev. apply elements_Add_Above; auto. rewrite distr_rev; simpl. @@ -2180,8 +2154,7 @@ Module OrdProperties (M:S). 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), - Morphism (E.eq==>Leibniz==>eqA==>eqA) f -> + (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. @@ -2189,7 +2162,7 @@ Module OrdProperties (M:S). set (f':=fun y x0 => f (fst y) (snd y) x0) in *. transitivity (fold_right f' i (rev (((x,e)::nil)++elements m1))). apply fold_right_eqlistA with (eqA:=eqke) (eqB:=eqA); auto. - intros (k1,e1) (k2,e2) a1 a2 (Hk,He) Ha; unfold f'; simpl in *; apply H; auto. + intros (k1,e1) (k2,e2) (Hk,He) a1 a2 Ha; unfold f'; simpl in *; apply P; auto. apply eqlistA_rev. simpl; apply elements_Add_Below; auto. rewrite distr_rev; simpl. diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 57cbbcc4..e4f8b4df 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -1,4 +1,3 @@ - (***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) @@ -9,26 +8,26 @@ (* Finite map library. *) -(* $Id: FMapFullAVL.v 10748 2008-04-03 18:28:26Z letouzey $ *) +(* $Id$ *) (** * FMapFullAVL - + This file contains some complements to [FMapAVL]. - - Functor [AvlProofs] proves that trees of [FMapAVL] are not only + - Functor [AvlProofs] proves that trees of [FMapAVL] are not only binary search trees, but moreover well-balanced ones. This is done by proving that all operations preserve the balancing. - - - We then pack the previous elements in a [IntMake] functor + + - We then pack the previous elements in a [IntMake] functor similar to the one of [FMapAVL], but richer. - - In final [IntMake_ord] functor, the [compare] function is - different from the one in [FMapAVL]: this non-structural + - In final [IntMake_ord] functor, the [compare] function is + different from the one in [FMapAVL]: this non-structural version is closer to the original Ocaml code. *) -Require Import Recdef FMapInterface FMapList ZArith Int FMapAVL. +Require Import Recdef FMapInterface FMapList ZArith Int FMapAVL ROmega. Set Implicit Arguments. Unset Strict Implicit. @@ -40,6 +39,8 @@ Import Raw.Proofs. Open Local Scope pair_scope. Open Local Scope Int_scope. +Ltac omega_max := i2z_refl; romega with Z. + Section Elt. Variable elt : Type. Implicit Types m r : t elt. @@ -52,11 +53,11 @@ Implicit Types m r : t elt. Inductive avl : t elt -> Prop := | RBLeaf : avl (Leaf _) - | RBNode : forall x e l r h, + | RBNode : forall x e l r h, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - h = max (height l) (height r) + 1 -> + h = max (height l) (height r) + 1 -> avl (Node l x e r h). @@ -64,28 +65,28 @@ Inductive avl : t elt -> Prop := Hint Constructors avl. -Lemma height_non_negative : forall (s : t elt), avl s -> +Lemma height_non_negative : forall (s : t elt), avl s -> height s >= 0. Proof. induction s; simpl; intros; auto with zarith. inv avl; intuition; omega_max. Qed. -Ltac avl_nn_hyp H := +Ltac avl_nn_hyp H := let nz := fresh "nz" in assert (nz := height_non_negative H). -Ltac avl_nn h := - let t := type of h in - match type of t with +Ltac avl_nn h := + let t := type of h in + match type of t with | Prop => avl_nn_hyp h | _ => match goal with H : avl h |- _ => avl_nn_hyp H end end. -(* Repeat the previous tactic. +(* Repeat the previous tactic. Drawback: need to clear the [avl _] hyps ... Thank you Ltac *) Ltac avl_nns := - match goal with + match goal with | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns | _ => idtac end. @@ -103,49 +104,49 @@ Hint Resolve avl_node. (** Results about [height] *) -Lemma height_0 : forall l, avl l -> height l = 0 -> +Lemma height_0 : forall l, avl l -> height l = 0 -> l = Leaf _. Proof. destruct 1; intuition; simpl in *. - avl_nns; simpl in *; elimtype False; omega_max. + avl_nns; simpl in *; exfalso; omega_max. Qed. (** * Empty map *) Lemma empty_avl : avl (empty elt). -Proof. +Proof. unfold empty; auto. Qed. (** * Helper functions *) -Lemma create_avl : - forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> +Lemma create_avl : + forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> avl (create l x e r). Proof. unfold create; auto. Qed. -Lemma create_height : - forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> +Lemma create_height : + forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> height (create l x e r) = max (height l) (height r) + 1. Proof. unfold create; intros; auto. Qed. -Lemma bal_avl : forall l x e r, avl l -> avl r -> +Lemma bal_avl : forall l x e r, avl l -> avl r -> -(3) <= height l - height r <= 3 -> avl (bal l x e r). Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; - inv avl; simpl in *; + inv avl; simpl in *; match goal with |- avl (assert_false _ _ _ _) => avl_nns | _ => repeat apply create_avl; simpl in *; auto end; omega_max. Qed. -Lemma bal_height_1 : forall l x e r, avl l -> avl r -> +Lemma bal_height_1 : forall l x e r, avl l -> avl r -> -(3) <= height l - height r <= 3 -> 0 <= height (bal l x e r) - max (height l) (height r) <= 1. Proof. @@ -153,25 +154,25 @@ Proof. inv avl; avl_nns; simpl in *; omega_max. Qed. -Lemma bal_height_2 : - forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> +Lemma bal_height_2 : + forall l x e r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> height (bal l x e r) == max (height l) (height r) +1. Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv avl; avl_nns; simpl in *; omega_max. Qed. -Ltac omega_bal := match goal with - | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => - generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); +Ltac omega_bal := match goal with + | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?e ?r ] => + generalize (bal_height_1 x e H H') (bal_height_2 x e H H'); omega_max end. (** * Insertion *) -Lemma add_avl_1 : forall m x e, avl m -> +Lemma add_avl_1 : forall m x e, avl m -> avl (add x e m) /\ 0 <= height (add x e m) - height m <= 1. -Proof. +Proof. intros m x e; functional induction (add x e m); intros; inv avl; simpl in *. intuition; try constructor; simpl; auto; try omega_max. (* LT *) @@ -196,8 +197,8 @@ Hint Resolve add_avl. (** * Extraction of minimum binding *) -Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) -> - avl (remove_min l x e r)#1 /\ +Lemma remove_min_avl_1 : forall l x e r h, avl (Node l x e r h) -> + avl (remove_min l x e r)#1 /\ 0 <= height (Node l x e r h) - height (remove_min l x e r)#1 <= 1. Proof. intros l x e r; functional induction (remove_min l x e r); simpl in *; intros. @@ -210,20 +211,20 @@ Proof. omega_bal. Qed. -Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) -> - avl (remove_min l x e r)#1. +Lemma remove_min_avl : forall l x e r h, avl (Node l x e r h) -> + avl (remove_min l x e r)#1. Proof. intros; generalize (remove_min_avl_1 H); intuition. Qed. (** * Merging two trees *) -Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 -> - -(2) <= height m1 - height m2 <= 2 -> - avl (merge m1 m2) /\ +Lemma merge_avl_1 : forall m1 m2, avl m1 -> avl m2 -> + -(2) <= height m1 - height m2 <= 2 -> + avl (merge m1 m2) /\ 0<= height (merge m1 m2) - max (height m1) (height m2) <=1. Proof. - intros m1 m2; functional induction (merge m1 m2); intros; + intros m1 m2; functional induction (merge m1 m2); intros; try factornode _x _x0 _x1 _x2 _x3 as m1. simpl; split; auto; avl_nns; omega_max. simpl; split; auto; avl_nns; omega_max. @@ -235,16 +236,16 @@ Proof. omega_bal. Qed. -Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 -> +Lemma merge_avl : forall m1 m2, avl m1 -> avl m2 -> -(2) <= height m1 - height m2 <= 2 -> avl (merge m1 m2). -Proof. +Proof. intros; generalize (merge_avl_1 H H0 H1); intuition. Qed. (** * Deletion *) -Lemma remove_avl_1 : forall m x, avl m -> +Lemma remove_avl_1 : forall m x, avl m -> avl (remove x m) /\ 0 <= height m - height (remove x m) <= 1. Proof. intros m x; functional induction (remove x m); intros. @@ -252,25 +253,25 @@ Proof. (* LT *) inv avl. destruct (IHt H0). - split. + split. apply bal_avl; auto. omega_max. omega_bal. (* EQ *) - inv avl. + inv avl. generalize (merge_avl_1 H0 H1 H2). intuition omega_max. (* GT *) inv avl. destruct (IHt H1). - split. + split. apply bal_avl; auto. omega_max. omega_bal. Qed. Lemma remove_avl : forall m x, avl m -> avl (remove x m). -Proof. +Proof. intros; generalize (remove_avl_1 x H); intuition. Qed. Hint Resolve remove_avl. @@ -278,7 +279,7 @@ Hint Resolve remove_avl. (** * Join *) -Lemma join_avl_1 : forall l x d r, avl l -> avl r -> +Lemma join_avl_1 : forall l x d r, avl l -> avl r -> avl (join l x d r) /\ 0<= height (join l x d r) - max (height l) (height r) <= 1. Proof. @@ -344,9 +345,9 @@ Hint Resolve concat_avl. (** split *) -Lemma split_avl : forall m x, avl m -> +Lemma split_avl : forall m x, avl m -> avl (split x m)#l /\ avl (split x m)#r. -Proof. +Proof. intros m x; functional induction (split x m); simpl; auto. rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. simpl; inversion_clear 1; auto. @@ -356,12 +357,12 @@ Qed. End Elt. Hint Constructors avl. -Section Map. +Section Map. Variable elt elt' : Type. -Variable f : elt -> elt'. +Variable f : elt -> elt'. Lemma map_height : forall m, height (map f m) = height m. -Proof. +Proof. destruct m; simpl; auto. Qed. @@ -375,10 +376,10 @@ End Map. Section Mapi. Variable elt elt' : Type. -Variable f : key -> elt -> elt'. +Variable f : key -> elt -> elt'. Lemma mapi_height : forall m, height (mapi f m) = height m. -Proof. +Proof. destruct m; simpl; auto. Qed. @@ -390,7 +391,7 @@ Qed. End Mapi. -Section Map_option. +Section Map_option. Variable elt elt' : Type. Variable f : key -> elt -> option elt'. @@ -412,12 +413,12 @@ Hypothesis mapr_avl : forall m', avl m' -> avl (mapr m'). Notation map2_opt := (map2_opt f mapl mapr). -Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 -> +Lemma map2_opt_avl : forall m1 m2, avl m1 -> avl m2 -> avl (map2_opt m1 m2). Proof. -intros m1 m2; functional induction (map2_opt m1 m2); auto; -factornode _x0 _x1 _x2 _x3 _x4 as r2; intros; -destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl; +intros m1 m2; functional induction (map2_opt m1 m2); auto; +factornode _x0 _x1 _x2 _x3 _x4 as r2; intros; +destruct (split_avl x1 H0); rewrite e1 in *; simpl in *; inv avl; auto using join_avl, concat_avl. Qed. @@ -437,11 +438,11 @@ End AvlProofs. (** * Encapsulation - We can implement [S] with balanced binary search trees. + We can implement [S] with balanced binary search trees. When compared to [FMapAVL], we maintain here two invariants (bst and avl) instead of only bst, which is enough for fulfilling the FMap interface. -*) +*) Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. @@ -450,32 +451,32 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Import Raw. Import Raw.Proofs. - Record bbst (elt:Type) := + Record bbst (elt:Type) := Bbst {this :> tree elt; is_bst : bst this; is_avl: avl this}. - + Definition t := bbst. Definition key := E.t. - + Section Elt. Variable elt elt' elt'': Type. Implicit Types m : t elt. - Implicit Types x y : key. - Implicit Types e : elt. + Implicit Types x y : key. + Implicit Types e : elt. Definition empty : t elt := Bbst (empty_bst elt) (empty_avl elt). Definition is_empty m : bool := is_empty m.(this). - Definition add x e m : t elt := + Definition add x e m : t elt := Bbst (add_bst x e m.(is_bst)) (add_avl x e m.(is_avl)). - Definition remove x m : t elt := + Definition remove x m : t elt := Bbst (remove_bst x m.(is_bst)) (remove_avl x m.(is_avl)). Definition mem x m : bool := mem x m.(this). Definition find x m : option elt := find x m.(this). - Definition map f m : t elt' := + Definition map f m : t elt' := Bbst (map_bst f m.(is_bst)) (map_avl f m.(is_avl)). - Definition mapi (f:key->elt->elt') m : t elt' := + Definition mapi (f:key->elt->elt') m : t elt' := Bbst (mapi_bst f m.(is_bst)) (mapi_avl f m.(is_avl)). - Definition map2 f m (m':t elt') : t elt'' := + Definition map2 f m (m':t elt') : t elt'' := Bbst (map2_bst f m.(is_bst) m'.(is_bst)) (map2_avl f m.(is_avl) m'.(is_avl)). Definition elements m : list (key*elt) := elements m.(this). Definition cardinal m := cardinal m.(this). @@ -492,14 +493,14 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Lemma MapsTo_1 : forall m x y e, E.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. intros m; exact (@MapsTo_1 _ m.(this)). Qed. - + Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_1; auto. apply m.(is_bst). Qed. - - Lemma mem_2 : forall m x, mem x m = true -> In x m. + + Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. unfold In, mem; intros m x; rewrite In_alt; simpl; apply mem_2; auto. Qed. @@ -530,7 +531,7 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. intros m x y e; exact (@remove_3 elt _ x y e m.(is_bst)). Qed. - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m x e; exact (@find_1 elt _ x e m.(is_bst)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@find_2 elt m.(this)). Qed. @@ -539,36 +540,36 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@fold_1 elt m.(this) m.(is_bst)). Qed. - Lemma elements_1 : forall m x e, + Lemma elements_1 : forall m x e, MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite elements_mapsto; auto. Qed. - Lemma elements_2 : forall m x e, + Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros; unfold elements, MapsTo, eq_key_elt; rewrite <- elements_mapsto; auto. Qed. - Lemma elements_3 : forall m, sort lt_key (elements m). + Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@elements_sort elt m.(this) m.(is_bst)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@elements_nodup elt m.(this) m.(is_bst)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intro m; exact (@elements_cardinal elt m.(this)). 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') /\ + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb cmp := Equiv (Cmp cmp). - Lemma Equivb_Equivb : forall cmp m m', + Lemma Equivb_Equivb : forall cmp m m', Equivb cmp m m' <-> Raw.Proofs.Equivb cmp m m'. - Proof. + Proof. intros; unfold Equivb, Equiv, Raw.Proofs.Equivb, In; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. generalize (H0 k); do 2 rewrite In_alt; intuition. @@ -576,23 +577,23 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. generalize (H0 k); do 2 rewrite <- In_alt; intuition. Qed. - Lemma equal_1 : forall m m' cmp, - Equivb cmp m m' -> equal cmp m m' = true. - Proof. - unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; + Lemma equal_1 : forall m m' cmp, + Equivb cmp m m' -> equal cmp m m' = true. + Proof. + unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite equal_Equivb; auto. - Qed. + Qed. - Lemma equal_2 : forall m m' cmp, + Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. - Proof. - unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; + Proof. + unfold equal; intros (m,b,a) (m',b',a') cmp; rewrite Equivb_Equivb; intros; simpl in *; rewrite <-equal_Equivb; auto. Qed. End Elt. - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m x e f; exact (@map_1 elt elt' f m.(this) x e). Qed. @@ -600,10 +601,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Proof. intros elt elt' m x f; do 2 unfold In in *; do 2 rewrite In_alt; simpl. apply map_2; auto. - Qed. + Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m x e f; exact (@mapi_1 elt elt' f m.(this) x e). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) @@ -613,10 +614,10 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. unfold find, map2, In; intros elt elt' elt'' m m' x f. do 2 rewrite In_alt; intros; simpl; apply map2_1; auto. apply m.(is_bst). @@ -624,9 +625,9 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - Proof. + Proof. unfold In, map2; intros elt elt' elt'' m m' x f. do 3 rewrite In_alt; intros; simpl in *; eapply map2_2; eauto. apply m.(is_bst). @@ -636,54 +637,54 @@ Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. End IntMake. -Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: - Sord with Module Data := D +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 Import MapS := IntMake(I)(X). Import AvlProofs. Import Raw.Proofs. Module Import MD := OrderedTypeFacts(D). Module LO := FMapList.Make_ord(X)(D). - Definition t := MapS.t D.t. + Definition t := MapS.t D.t. - Definition cmp e e' := + Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. - Definition elements (m:t) := + Definition elements (m:t) := LO.MapS.Build_slist (Raw.Proofs.elements_sort m.(is_bst)). - (** * As comparison function, we propose here a non-structural - version faithful to the code of Ocaml's Map library, instead of + (** * As comparison function, we propose here a non-structural + version faithful to the code of Ocaml's Map library, instead of the structural version of FMapAVL *) - Fixpoint cardinal_e (e:Raw.enumeration D.t) := - match e with + Fixpoint cardinal_e (e:Raw.enumeration D.t) := + match e with | Raw.End => 0%nat | Raw.More _ _ r e => S (Raw.cardinal r + cardinal_e e) end. - Lemma cons_cardinal_e : forall m e, + Lemma cons_cardinal_e : forall m e, cardinal_e (Raw.cons m e) = (Raw.cardinal m + cardinal_e e)%nat. Proof. induction m; simpl; intros; auto. rewrite IHm1; simpl; rewrite <- plus_n_Sm; auto with arith. Qed. - Definition cardinal_e_2 ee := + Definition cardinal_e_2 ee := (cardinal_e (fst ee) + cardinal_e (snd ee))%nat. - Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t) - { measure cardinal_e_2 ee } : comparison := - match ee with + Function compare_aux (ee:Raw.enumeration D.t * Raw.enumeration D.t) + { measure cardinal_e_2 ee } : comparison := + match ee with | (Raw.End, Raw.End) => Eq | (Raw.End, Raw.More _ _ _ _) => Lt | (Raw.More _ _ _ _, Raw.End) => Gt | (Raw.More x1 d1 r1 e1, Raw.More x2 d2 r2 e2) => match X.compare x1 x2 with - | EQ _ => match D.compare d1 d2 with + | EQ _ => match D.compare d1 d2 with | EQ _ => compare_aux (Raw.cons r1 e1, Raw.cons r2 e2) | LT _ => Lt | GT _ => Gt @@ -693,10 +694,10 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: end end. Proof. - intros; unfold cardinal_e_2; simpl; + intros; unfold cardinal_e_2; simpl; abstract (do 2 rewrite cons_cardinal_e; romega with * ). Defined. - + Definition Cmp c := match c with | Eq => LO.eq_list @@ -704,7 +705,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: | Gt => (fun l1 l2 => LO.lt_list l2 l1) end. - Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, + Lemma cons_Cmp : forall c x1 x2 d1 d2 l1 l2, X.eq x1 x2 -> D.eq d1 d2 -> Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). Proof. @@ -712,23 +713,23 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Qed. Hint Resolve cons_Cmp. - Lemma compare_aux_Cmp : forall e, + Lemma compare_aux_Cmp : forall e, Cmp (compare_aux e) (flatten_e (fst e)) (flatten_e (snd e)). Proof. - intros e; functional induction (compare_aux e); simpl in *; + intros e; functional induction (compare_aux e); simpl in *; auto; intros; try clear e0; try clear e3; try MX.elim_comp; auto. rewrite 2 cons_1 in IHc; auto. Qed. - Lemma compare_Cmp : forall m1 m2, - Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))) + Lemma compare_Cmp : forall m1 m2, + Cmp (compare_aux (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))) (Raw.elements m1) (Raw.elements m2). Proof. - intros. + intros. assert (H1:=cons_1 m1 (Raw.End _)). assert (H2:=cons_1 m2 (Raw.End _)). simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2. - apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _), + apply (@compare_aux_Cmp (Raw.cons m1 (Raw.End _), Raw.cons m2 (Raw.End _))). Qed. @@ -737,15 +738,15 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Definition compare (s s':t) : Compare lt eq s s'. Proof. - intros (s,b,a) (s',b',a'). + destruct s as (s,b,a), s' as (s',b',a'). generalize (compare_Cmp s s'). destruct compare_aux; intros; [apply EQ|apply LT|apply GT]; red; auto. Defined. - + (* Proofs about [eq] and [lt] *) - Definition selements (m1 : t) := + Definition selements (m1 : t) := LO.MapS.Build_slist (elements_sort m1.(is_bst)). Definition seq (m1 m2 : t) := LO.eq (selements m1) (selements m2). @@ -782,7 +783,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Qed. Lemma eq_refl : forall m : t, eq m m. - Proof. + Proof. intros; rewrite eq_seq; unfold seq; intros; apply LO.eq_refl. Qed. @@ -799,13 +800,13 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Proof. - intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; + intros m1 m2 m3; rewrite 3 lt_slt; unfold slt; intros; eapply LO.lt_trans; eauto. Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. - intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; + intros m1 m2; rewrite lt_slt, eq_seq; unfold slt, seq; intros; apply LO.lt_not_eq; auto. Qed. @@ -816,8 +817,8 @@ End IntMake_ord. 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 +Module Make_ord (X: OrderedType)(D: OrderedType) + <: Sord with Module Data := D with Module MapS.E := X :=IntMake_ord(Z_as_Int)(X)(D). diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index ebdc9c57..e60cca9d 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapInterface.v 11699 2008-12-18 11:49:08Z letouzey $ *) +(* $Id$ *) -(** * Finite map library *) +(** * Finite map library *) (** This file proposes interfaces for finite maps *) @@ -16,8 +16,8 @@ Require Export Bool DecidableType OrderedType. Set Implicit Arguments. Unset Strict Implicit. -(** When compared with Ocaml Map, this signature has been split in - several parts : +(** When compared with Ocaml Map, this signature has been split in + several parts : - The first parts [WSfun] and [WS] propose signatures for weak maps, which are maps with no ordering on the key type nor the @@ -29,18 +29,18 @@ Unset Strict Implicit. (add, find, ...). The only function that asks for more is [equal], whose first argument should be a comparison on data. - - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the - case where the key type is ordered. The main novelty is that + - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the + case where the key type is ordered. The main novelty is that [elements] is required to produce sorted lists. - - Finally, [Sord] extends [S] with a complete comparison function. For - that, the data type should have a decidable total ordering as well. + - Finally, [Sord] extends [S] with a complete comparison function. For + that, the data type should have a decidable total ordering as well. If unsure, what you're looking for is probably [S]: apart from [Sord], - all other signatures are subsets of [S]. + all other signatures are subsets of [S]. + + Some additional differences with Ocaml: - Some additional differences with Ocaml: - - no [iter] function, useless since Coq is purely functional - [option] types are used instead of [Not_found] exceptions - more functions are provided: [elements] and [cardinal] and [map2] @@ -51,7 +51,7 @@ Unset Strict Implicit. Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. (** ** Weak signature for maps - + No requirements for an ordering on keys nor elements, only decidability of equality on keys. First, a functorial signature: *) @@ -61,8 +61,8 @@ Module Type WSfun (E : DecidableType). Parameter t : Type -> Type. (** the abstract type of maps *) - - Section Types. + + Section Types. Variable elt:Type. @@ -73,61 +73,61 @@ Module Type WSfun (E : DecidableType). (** 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], + (** [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], + 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], + (** [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], + (** [mem x m] returns [true] if [m] contains a binding for [x], and [false] otherwise. *) Variable elt' elt'' : Type. Parameter map : (elt -> elt') -> t elt -> t elt'. - (** [map f m] returns a map with same domain as [m], where the associated + (** [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 + (** Same as [map], but the function receives as arguments both the key and the associated value for each binding of the map. *) - Parameter map2 : + Parameter map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' -> t elt''. - (** [map2 f m m'] creates a new map whose bindings belong to the ones - of either [m] or [m']. The presence and value for a key [k] is - determined by [f e e'] where [e] and [e'] are the (optional) bindings + (** [map2 f m m'] creates a new map whose bindings belong to the ones + of either [m] or [m']. The presence and value for a key [k] is + determined by [f e e'] where [e] and [e'] are the (optional) bindings of [k] in [m] and [m']. *) Parameter elements : t elt -> list (key*elt). - (** [elements m] returns an assoc list corresponding to the bindings + (** [elements m] returns an assoc list corresponding to the bindings of [m], in any order. *) - Parameter cardinal : t elt -> nat. + 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] + (** [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 + (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, + that is, contain equal keys and associate them with equal data. + [cmp] is the equality predicate used to compare the data associated with the keys. *) - Section Spec. - + Section Spec. + Variable m m' m'' : t elt. Variable x y z : key. Variable e e' : elt. @@ -139,24 +139,24 @@ Module Type WSfun (E : DecidableType). Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p'). - - Definition eq_key_elt (p p':key*elt) := + + Definition eq_key_elt (p p':key*elt) := E.eq (fst p) (fst p') /\ (snd p) = (snd p'). (** Specification of [MapsTo] *) Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. - + (** Specification of [mem] *) Parameter mem_1 : In x m -> mem x m = true. - Parameter mem_2 : mem x m = true -> In x m. - + Parameter mem_2 : mem x m = true -> In x m. + (** Specification of [empty] *) Parameter empty_1 : Empty empty. (** Specification of [is_empty] *) - Parameter is_empty_1 : Empty m -> is_empty m = true. + Parameter is_empty_1 : Empty m -> is_empty m = true. Parameter is_empty_2 : is_empty m = true -> Empty m. - + (** Specification of [add] *) Parameter add_1 : E.eq x y -> MapsTo y e (add x e m). Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). @@ -168,50 +168,50 @@ Module Type WSfun (E : DecidableType). Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. (** Specification of [find] *) - Parameter find_1 : MapsTo x e m -> find x m = Some e. + Parameter find_1 : MapsTo x e m -> find x m = Some e. Parameter find_2 : find x m = Some e -> MapsTo x e m. (** Specification of [elements] *) - Parameter elements_1 : + Parameter elements_1 : MapsTo x e m -> InA eq_key_elt (x,e) (elements m). - Parameter elements_2 : + Parameter elements_2 : InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. - (** When compared with ordered maps, here comes the only + (** When compared with ordered maps, here comes the only property that is really weaker: *) - Parameter elements_3w : NoDupA eq_key (elements m). + Parameter elements_3w : NoDupA eq_key (elements m). (** Specification of [cardinal] *) Parameter cardinal_1 : cardinal m = length (elements m). - (** Specification of [fold] *) + (** Specification of [fold] *) Parameter fold_1 : forall (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. (** Equality of maps *) - + (** Caveat: there are at least three distinct equality predicates on maps. - - The simpliest (and maybe most natural) way is to consider keys up to - their equivalence [E.eq], but elements up to Leibniz equality, in + - The 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 + the [equal] function, since this function (for compatibility with + ocaml) expects a boolean comparison [cmp] that may identify more + elements than Leibniz. So logical specification of [equal] is done via another predicate [Equivb] - This predicate [Equivb] is quite ad-hoc with its boolean [cmp], it can be generalized in a [Equiv] expecting a more general (possibly non-decidable) equality predicate on elements *) Definition Equal m m' := forall y, find y m = find y m'. - Definition Equiv (eq_elt:elt->elt->Prop) m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). + Definition Equiv (eq_elt:elt->elt->Prop) m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e'). Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp). (** Specification of [equal] *) - Variable cmp : elt -> elt -> bool. + Variable cmp : elt -> elt -> bool. Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true. Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'. @@ -220,26 +220,26 @@ Module Type WSfun (E : DecidableType). End Types. (** Specification of [map] *) - Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). - Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. - + (** Specification of [mapi] *) Parameter mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Parameter mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m. (** Specification of [map2] *) Parameter map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). Parameter map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Hint Immediate MapsTo_1 mem_2 is_empty_2 @@ -252,13 +252,13 @@ Module Type WSfun (E : DecidableType). End WSfun. -(** ** Static signature for Weak Maps +(** ** Static signature for Weak Maps Similar to [WSfun] but expressed in a self-contained way. *) -Module Type WS. +Module Type WS. Declare Module E : DecidableType. - Include Type WSfun E. + Include WSfun E. End WS. @@ -266,7 +266,7 @@ End WS. (** ** Maps on ordered keys, functorial signature *) Module Type Sfun (E : OrderedType). - Include Type WSfun E. + Include WSfun E. Section elt. Variable elt:Type. Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p'). @@ -274,7 +274,7 @@ Module Type Sfun (E : OrderedType). Parameter elements_3 : forall m, sort lt_key (elements m). (** Remark: since [fold] is specified via [elements], this stronger specification of [elements] has an indirect impact on [fold], - which can now be proved to receive elements in increasing order. *) + which can now be proved to receive elements in increasing order. *) End elt. End Sfun. @@ -282,9 +282,9 @@ End Sfun. (** ** Maps on ordered keys, self-contained signature *) -Module Type S. +Module Type S. Declare Module E : OrderedType. - Include Type Sfun E. + Include Sfun E. End S. @@ -293,28 +293,28 @@ End S. Module Type Sord. - Declare Module Data : OrderedType. - Declare Module MapS : S. + Declare Module Data : OrderedType. + Declare Module MapS : S. Import MapS. - - Definition t := MapS.t Data.t. + + Definition t := MapS.t Data.t. Parameter eq : t -> t -> Prop. - Parameter lt : t -> t -> Prop. - + Parameter lt : t -> t -> Prop. + Axiom eq_refl : forall m : t, eq m m. Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. - Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end. + Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end. Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'. Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'. Parameter compare : forall m1 m2, Compare lt eq m1 m2. - (** Total ordering between maps. [Data.compare] is a total ordering + (** Total ordering between maps. [Data.compare] is a total ordering used to compare data associated with equal keys in the two maps. *) End Sord. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 0ec5ef36..56fc35d8 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapList.v 11699 2008-12-18 11:49:08Z letouzey $ *) +(* $Id$ *) (** * Finite map library *) @@ -30,7 +30,7 @@ Definition t (elt:Type) := list (X.t * elt). Section Elt. Variable elt : Type. -Notation eqk := (eqk (elt:=elt)). +Notation eqk := (eqk (elt:=elt)). Notation eqke := (eqke (elt:=elt)). Notation ltk := (ltk (elt:=elt)). Notation MapsTo := (MapsTo (elt:=elt)). @@ -45,7 +45,7 @@ Definition empty : t elt := nil. Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. Lemma empty_1 : Empty empty. -Proof. +Proof. unfold Empty,empty. intros a e. intro abs. @@ -54,7 +54,7 @@ Qed. Hint Resolve empty_1. Lemma empty_sorted : Sort empty. -Proof. +Proof. unfold empty; auto. Qed. @@ -62,7 +62,7 @@ Qed. Definition is_empty (l : t elt) : bool := if l then true else false. -Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. +Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. Proof. unfold Empty, PX.MapsTo. intros m. @@ -72,7 +72,7 @@ Proof. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. -Proof. +Proof. intros m. case m;auto. intros p l abs. @@ -93,12 +93,12 @@ Function mem (k : key) (s : t elt) {struct s} : bool := end. Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true. -Proof. - intros m Hm x; generalize Hm; clear Hm. +Proof. + intros m Hm x; generalize Hm; clear Hm. functional induction (mem x m);intros sorted belong1;trivial. - + inversion belong1. inversion H. - + absurd (In x ((k', _x) :: l));try assumption. apply Sort_Inf_NotIn with _x;auto. @@ -107,13 +107,13 @@ Proof. elim (In_inv belong1);auto. intro abs. absurd (X.eq x k');auto. -Qed. +Qed. -Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. +Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. Proof. intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail). - exists _x; auto. + exists _x; auto. induction IHb; auto. exists x0; auto. inversion_clear sorted; auto. @@ -124,7 +124,7 @@ Qed. Function find (k:key) (s: t elt) {struct s} : option elt := match s with | nil => None - | (k',x)::s' => + | (k',x)::s' => match X.compare k k' with | LT _ => None | EQ _ => Some x @@ -138,7 +138,7 @@ Proof. functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto. Qed. -Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. +Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. Proof. intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (find x m);simpl; subst; try clear H_eq_1. @@ -150,9 +150,9 @@ Proof. clear e1;generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. clear e1;inversion_clear 2. - compute in H0; destruct H0; intuition congruence. + compute in H0; destruct H0; intuition congruence. generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. - + clear e1; do 2 inversion_clear 1; auto. compute in H2; destruct H2; order. Qed. @@ -177,10 +177,10 @@ Proof. functional induction (add x e m);simpl;auto. Qed. -Lemma add_2 : forall m x y e e', +Lemma add_2 : forall m x y e e', ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. - intros m x y e e'. + intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. functional induction (add x e' m) ;simpl;auto; clear e0. subst;auto. @@ -191,7 +191,7 @@ Proof. auto. intros y' e'' eqky'; inversion_clear 1; intuition. Qed. - + Lemma add_3 : forall m x y e e', ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. @@ -200,15 +200,15 @@ Proof. functional induction (add x e' m);simpl; intros. apply (In_inv_3 H0); compute; auto. apply (In_inv_3 H0); compute; auto. - constructor 2; apply (In_inv_3 H0); compute; auto. + constructor 2; apply (In_inv_3 H0); compute; auto. inversion_clear H0; auto. Qed. -Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), +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. + induction m. simpl; intuition. intros. destruct a as (x'',e''). @@ -227,7 +227,7 @@ Proof. simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. constructor; auto. apply Inf_eq with (x',e'); auto. -Qed. +Qed. (** * [remove] *) @@ -240,48 +240,48 @@ Function remove (k : key) (s : t elt) {struct s} : t elt := | EQ _ => l | GT _ => (k',x) :: remove k l end - end. + end. Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m). Proof. intros m Hm x y; generalize Hm; clear Hm. functional induction (remove x m);simpl;intros;subst. - + red; inversion 1; inversion H1. apply Sort_Inf_NotIn with x0; auto. clear e0;constructor; compute; order. - + clear e0;inversion_clear Hm. - apply Sort_Inf_NotIn with x0; auto. + apply Sort_Inf_NotIn with x0; auto. apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto. clear e0;inversion_clear Hm. assert (notin:~ In y (remove x l)) by auto. intros (x1,abs). - inversion_clear abs. + inversion_clear abs. compute in H2; destruct H2; order. apply notin; exists x1; auto. Qed. -Lemma remove_2 : forall m (Hm:Sort m) x y e, +Lemma remove_2 : forall m (Hm:Sort m) x y e, ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. - functional induction (remove x m);subst;auto; - match goal with + functional induction (remove x m);subst;auto; + match goal with | [H: X.compare _ _ = _ |- _ ] => clear H | _ => idtac end. inversion_clear 3; auto. compute in H1; destruct H1; order. - + inversion_clear 1; inversion_clear 2; auto. Qed. -Lemma remove_3 : forall m (Hm:Sort m) x y e, +Lemma remove_3 : forall m (Hm:Sort m) x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. @@ -289,10 +289,10 @@ Proof. inversion_clear 1; inversion_clear 1; auto. Qed. -Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), +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. + induction m. simpl; intuition. intros. destruct a as (x'',e''). @@ -311,31 +311,31 @@ Proof. intros. destruct a as (x',e'). simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. -Qed. +Qed. (** * [elements] *) Definition elements (m: t elt) := m. -Lemma elements_1 : forall m x e, +Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m). Proof. auto. Qed. -Lemma elements_2 : forall m x e, +Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. -Proof. +Proof. auto. Qed. -Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). -Proof. +Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). +Proof. auto. Qed. -Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). -Proof. +Lemma elements_3w : forall m (Hm:Sort m), NoDupA eqk (elements m). +Proof. intros. apply Sort_NoDupA. apply elements_3; auto. @@ -351,30 +351,30 @@ Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc:A) {struct m} : A := Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. -Proof. +Proof. intros; functional induction (fold f m i); auto. Qed. (** * [equal] *) -Function equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool := - match m, m' with +Function equal (cmp:elt->elt->bool)(m m' : t elt) {struct m} : bool := + match m, m' with | nil, nil => true - | (x,e)::l, (x',e')::l' => - match X.compare x x' with + | (x,e)::l, (x',e')::l' => + match X.compare x x' with | EQ _ => cmp e e' && equal cmp l l' | _ => false - end - | _, _ => false + end + | _, _ => false end. -Definition Equivb cmp m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). +Definition Equivb cmp m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. +Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, + Equivb cmp m m' -> equal cmp m m' = true. +Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; intuition; subst. @@ -407,7 +407,7 @@ Proof. destruct (X.compare x x'); try contradiction; clear y. destruct (H0 x). - assert (In x ((x',e')::l')). + assert (In x ((x',e')::l')). apply H; auto. exists e; auto. destruct (In_inv H3). @@ -418,7 +418,7 @@ Proof. elim (Sort_Inf_NotIn H5 H7 H4). destruct (H0 x'). - assert (In x' ((x,e)::l)). + assert (In x' ((x,e)::l)). apply H2; auto. exists e'; auto. destruct (In_inv H3). @@ -430,7 +430,7 @@ Proof. destruct m; destruct m';try contradiction. - + clear H1;destruct p as (k,e). destruct (H0 k). destruct H1. @@ -447,18 +447,18 @@ Proof. Qed. -Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, +Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. - functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; - intuition; try discriminate; subst; + functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; + intuition; try discriminate; subst; try match goal with H: X.compare _ _ = _ |- _ => clear H end. inversion H0. inversion_clear Hm;inversion_clear Hm'. - destruct (andb_prop _ _ H); clear H. + destruct (andb_prop _ _ H); clear H. destruct (IHb H1 H3 H6). destruct (In_inv H0). exists e'; constructor; split; trivial; apply X.eq_trans with x; auto. @@ -467,7 +467,7 @@ Proof. exists e''; auto. inversion_clear Hm;inversion_clear Hm'. - destruct (andb_prop _ _ H); clear H. + destruct (andb_prop _ _ H); clear H. destruct (IHb H1 H3 H6). destruct (In_inv H0). exists e; constructor; split; trivial; apply X.eq_trans with x'; auto. @@ -476,15 +476,15 @@ Proof. exists e''; auto. inversion_clear Hm;inversion_clear Hm'. - destruct (andb_prop _ _ H); clear H. + destruct (andb_prop _ _ H); clear H. destruct (IHb H2 H4 H7). inversion_clear H0. destruct H9; simpl in *; subst. - inversion_clear H1. + inversion_clear H1. destruct H9; simpl in *; subst; auto. elim (Sort_Inf_NotIn H4 H5). exists e'0; apply MapsTo_eq with k; auto; order. - inversion_clear H1. + inversion_clear H1. destruct H0; simpl in *; subst; auto. elim (Sort_Inf_NotIn H2 H3). exists e0; apply MapsTo_eq with k; auto; order. @@ -494,7 +494,7 @@ Qed. (** This lemma isn't part of the spec of [Equivb], but is used in [FMapAVL] *) Lemma equal_cons : forall cmp l1 l2 x y, Sort (x::l1) -> Sort (y::l2) -> - eqk x y -> cmp (snd x) (snd y) = true -> + eqk x y -> cmp (snd x) (snd y) = true -> (Equivb cmp l1 l2 <-> Equivb cmp (x :: l1) (y :: l2)). Proof. intros. @@ -517,38 +517,38 @@ Qed. Variable elt':Type. (** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' := + +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) {struct m} : t elt' := +Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := match m with | nil => nil | (k,e)::m' => (k,f k e) :: mapi f m' end. End Elt. -Section Elt2. -(* A new section is necessary for previous definitions to work +Section Elt2. +(* A new section is necessary for previous definitions to work with different [elt], especially [MapsTo]... *) - + Variable elt elt' : Type. (** Specification of [map] *) -Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), +Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros m x e f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. - + destruct a as (x',e'). - simpl. + simpl. inversion_clear 1. constructor 1. unfold eqke in *; simpl in *; intuition congruence. @@ -556,15 +556,15 @@ Proof. unfold MapsTo in *; auto. Qed. -Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), +Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. - intros m x f. + intros m x f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. - + destruct a as (x',e). intros hyp. inversion hyp. clear hyp. @@ -578,9 +578,9 @@ Proof. Qed. Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'), - lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt) (x,e) m -> lelistA (@ltk elt') (x,e') (map f m). -Proof. +Proof. induction m; simpl; auto. intros. destruct a as (x0,e0). @@ -589,30 +589,30 @@ Qed. Hint Resolve map_lelistA. -Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), +Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), sort (@ltk elt') (map f m). -Proof. +Proof. induction m; simpl; auto. intros. destruct a as (x',e'). inversion_clear Hm. constructor; auto. exact (map_lelistA _ _ H0). -Qed. - +Qed. + (** Specification of [mapi] *) -Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> +Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros m x e f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. - + destruct a as (x',e'). - simpl. + simpl. inversion_clear 1. exists x'. destruct H0; simpl in *. @@ -621,18 +621,18 @@ Proof. unfold eqke in *; simpl in *; intuition congruence. destruct IHm as (y, hyp); auto. exists y; intuition. -Qed. +Qed. -Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), +Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. - intros m x f. + intros m x f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. - + destruct a as (x',e). intros hyp. inversion hyp. clear hyp. @@ -646,9 +646,9 @@ Proof. Qed. Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'), - lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt) (x,e) m -> lelistA (@ltk elt') (x,f x e) (mapi f m). -Proof. +Proof. induction m; simpl; auto. intros. destruct a as (x',e'). @@ -657,7 +657,7 @@ Qed. Hint Resolve mapi_lelistA. -Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), +Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), sort (@ltk elt') (mapi f m). Proof. induction m; simpl; auto. @@ -666,7 +666,7 @@ Proof. inversion_clear Hm; auto. Qed. -End Elt2. +End Elt2. Section Elt3. (** * [map2] *) @@ -674,27 +674,27 @@ Section Elt3. Variable elt elt' elt'' : Type. Variable f : option elt -> option elt' -> option elt''. -Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := - match o with +Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := + match o with | Some e => (k,e)::l | None => l end. -Fixpoint map2_l (m : t elt) : t elt'' := - match m with - | nil => nil +Fixpoint map2_l (m : t elt) : t elt'' := + match m with + | nil => nil | (k,e)::l => option_cons k (f (Some e) None) (map2_l l) - end. + end. -Fixpoint map2_r (m' : t elt') : t elt'' := - match m' with - | nil => nil +Fixpoint map2_r (m' : t elt') : t elt'' := + match m' with + | nil => nil | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l') - end. + end. Fixpoint map2 (m : t elt) : t elt' -> t elt'' := match m with - | nil => map2_r + | nil => map2_r | (k,e) :: l => fix map2_aux (m' : t elt') : t elt'' := match m' with @@ -706,7 +706,7 @@ Fixpoint map2 (m : t elt) : t elt' -> t elt'' := | GT _ => option_cons k' (f None (Some e')) (map2_aux l') end end - end. + end. Notation oee' := (option elt * option elt')%type. @@ -724,14 +724,14 @@ Fixpoint combine (m : t elt) : t elt' -> t oee' := | GT _ => (k',(None,Some e'))::combine_aux l' end end - end. + end. -Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := +Definition fold_right_pair (A B C:Type)(f: A->B->C->C)(l:list (A*B))(i:C) := List.fold_right (fun p => f (fst p) (snd p)) i l. -Definition map2_alt m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in +Definition map2_alt m m' := + let m0 : t oee' := combine m m' in + let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in fold_right_pair (option_cons (A:=elt'')) m1 nil. Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'. @@ -758,20 +758,20 @@ Proof. apply IHm'. Qed. -Lemma combine_lelistA : - forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), - lelistA (@ltk elt) (x,e) m -> - lelistA (@ltk elt') (x,e') m' -> +Lemma combine_lelistA : + forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), + lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt') (x,e') m' -> lelistA (@ltk oee') (x,e'') (combine m m'). Proof. - induction m. + induction m. intros. simpl. exact (map_lelistA _ _ H0). - induction m'. + induction m'. intros. destruct a. - replace (combine ((t0, e0) :: m) nil) with + replace (combine ((t0, e0) :: m) nil) with (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. exact (map_lelistA _ _ H). intros. @@ -784,18 +784,18 @@ Proof. Qed. Hint Resolve combine_lelistA. -Lemma combine_sorted : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), +Lemma combine_sorted : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), sort (@ltk oee') (combine m m'). Proof. - induction m. + induction m. intros; clear Hm. simpl. apply map_sorted; auto. - induction m'. + induction m'. intros; clear Hm'. destruct a. - replace (combine ((t0, e) :: m) nil) with + replace (combine ((t0, e) :: m) nil) with (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. apply map_sorted; auto. intros. @@ -805,11 +805,11 @@ Proof. inversion_clear Hm. constructor; auto. assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto. - exact (combine_lelistA _ H0 H1). + exact (combine_lelistA _ H0 H1). inversion_clear Hm; inversion_clear Hm'. constructor; auto. assert (lelistA (ltk (elt:=elt')) (k, e') m') by (apply Inf_eq with (k',e'); auto). - exact (combine_lelistA _ H0 H3). + exact (combine_lelistA _ H0 H3). inversion_clear Hm; inversion_clear Hm'. constructor; auto. change (lelistA (ltk (elt:=oee')) (k', (None, Some e')) @@ -818,8 +818,8 @@ Proof. exact (combine_lelistA _ H3 H2). Qed. -Lemma map2_sorted : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), +Lemma map2_sorted : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), sort (@ltk elt'') (map2 m m'). Proof. intros. @@ -829,7 +829,7 @@ Proof. set (l0:=combine m m') in *; clearbody l0. set (f':= fun p : oee' => f (fst p) (snd p)). assert (H1:=map_sorted (elt' := option elt'') H0 f'). - set (l1:=map f' l0) in *; clearbody l1. + set (l1:=map f' l0) in *; clearbody l1. clear f' f H0 l0 Hm Hm' m m'. induction l1. simpl; auto. @@ -848,16 +848,16 @@ Proof. apply IHl1; auto. apply Inf_lt with (t1, None (A:=elt'')); auto. Qed. - -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None + +Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None | _, _ => Some (o,o') end. -Lemma combine_1 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), - find x (combine m m') = at_least_one (find x m) (find x m'). +Lemma combine_1 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), + find x (combine m m') = at_least_one (find x m) (find x m'). Proof. induction m. intros. @@ -881,32 +881,32 @@ Proof. destruct a as (k,e); destruct a0 as (k',e'); simpl. inversion Hm; inversion Hm'; subst. destruct (X.compare k k'); simpl; - destruct (X.compare x k); + destruct (X.compare x k); elim_comp || destruct (X.compare x k'); simpl; auto. rewrite IHm; auto; simpl; elim_comp; auto. rewrite IHm; auto; simpl; elim_comp; auto. rewrite IHm; auto; simpl; elim_comp; auto. change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). - rewrite IHm'; auto. + rewrite IHm'; auto. simpl find; elim_comp; auto. change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). - rewrite IHm'; auto. + rewrite IHm'; auto. simpl find; elim_comp; auto. - change (find x (combine ((k, e) :: m) m') = + change (find x (combine ((k, e) :: m) m') = at_least_one (find x m) (find x m')). - rewrite IHm'; auto. + rewrite IHm'; auto. simpl find; elim_comp; auto. Qed. -Definition at_least_one_then_f (o:option elt)(o':option elt') := - match o, o' with - | None, None => None +Definition at_least_one_then_f (o:option elt)(o':option elt') := + match o, o' with + | None, None => None | _, _ => f o o' end. -Lemma map2_0 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), - find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). +Lemma map2_0 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), + find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). Proof. intros. rewrite <- map2_alt_equiv. @@ -915,7 +915,7 @@ Proof. assert (H2:=combine_sorted Hm Hm'). set (f':= fun p : oee' => f (fst p) (snd p)). set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. + set (o:=find x m) in *; clearbody o. set (o':=find x m') in *; clearbody o'. clear Hm Hm' m m'. generalize H; clear H. @@ -984,10 +984,10 @@ Qed. (** Specification of [map2] *) -Lemma map2_1 : +Lemma map2_1 : forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), - In x m \/ In x m' -> - find x (map2 m m') = f (find x m) (find x m'). + In x m \/ In x m' -> + find x (map2 m m') = f (find x m) (find x m'). Proof. intros. rewrite map2_0; auto. @@ -997,10 +997,10 @@ Proof. rewrite (find_1 Hm' H). destruct (find x m); simpl; auto. Qed. - -Lemma map2_2 : - forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), - In x (map2 m m') -> In x m \/ In x m'. + +Lemma map2_2 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), + In x (map2 m m') -> In x m \/ In x m'. Proof. intros. destruct H as (e,H). @@ -1008,9 +1008,9 @@ Proof. rewrite (find_1 (map2_sorted Hm Hm') H). generalize (@find_2 _ m x). generalize (@find_2 _ m' x). - destruct (find x m); + destruct (find x m); destruct (find x m'); simpl; intros. - left; exists e0; auto. + left; exists e0; auto. left; exists e0; auto. right; exists e0; auto. discriminate. @@ -1020,31 +1020,31 @@ End Elt3. End Raw. Module Make (X: OrderedType) <: S with Module E := X. -Module Raw := Raw X. +Module Raw := Raw X. Module E := X. Definition key := E.t. -Record slist (elt:Type) := +Record slist (elt:Type) := {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. -Definition t (elt:Type) : Type := slist elt. +Definition t (elt:Type) : Type := slist elt. -Section Elt. - Variable elt elt' elt'':Type. +Section Elt. + Variable elt elt' elt'':Type. Implicit Types m : t elt. - Implicit Types x y : key. + Implicit Types x y : key. Implicit Types e : elt. Definition empty : t elt := Build_slist (Raw.empty_sorted elt). Definition is_empty m : bool := Raw.is_empty m.(this). Definition add x e m : t elt := Build_slist (Raw.add_sorted m.(sorted) x e). Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x). + Definition remove x m : t elt := Build_slist (Raw.remove_sorted m.(sorted) x). Definition mem x m : bool := Raw.mem x m.(this). Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f). Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f). - Definition map2 f m (m':t elt') : t elt'' := + Definition map2 f m (m':t elt') : t elt'' := Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)). Definition elements m : list (key*elt) := @Raw.elements elt m.(this). Definition cardinal m := length m.(this). @@ -1056,9 +1056,9 @@ Section Elt. Definition Empty m : Prop := Raw.Empty 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 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). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. @@ -1095,7 +1095,7 @@ Section Elt. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(sorted)). Qed. - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(sorted)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. @@ -1104,9 +1104,9 @@ Section Elt. Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. - Lemma elements_3 : forall m, sort lt_key (elements m). + Lemma elements_3 : forall m, sort lt_key (elements m). Proof. intros m; exact (@Raw.elements_3 elt m.(this) m.(sorted)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(sorted)). Qed. Lemma cardinal_1 : forall m, cardinal m = length (elements m). @@ -1116,22 +1116,22 @@ Section Elt. fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. - Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. + Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted)). Qed. End Elt. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) @@ -1139,58 +1139,58 @@ Section Elt. Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - intros elt elt' elt'' m m' x f; + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. + intros elt elt' elt'' m m' x f; exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - Proof. - intros elt elt' elt'' m m' x f; + Proof. + intros elt elt' elt'' m m' x f; exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x). Qed. End Make. -Module Make_ord (X: OrderedType)(D : OrderedType) <: -Sord with Module Data := D +Module Make_ord (X: OrderedType)(D : OrderedType) <: +Sord with Module Data := D with Module MapS.E := X. Module Data := D. -Module MapS := Make(X). +Module MapS := Make(X). Import MapS. Module MD := OrderedTypeFacts(D). Import MD. -Definition t := MapS.t D.t. +Definition t := MapS.t D.t. Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. -Fixpoint eq_list (m m' : list (X.t * D.t)) { struct m } : Prop := - match m, m' with +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 + | (x,e)::l, (x',e')::l' => + match X.compare x x' with | EQ _ => D.eq e e' /\ eq_list l l' | _ => False - end + end | _, _ => False end. Definition eq m m' := eq_list m.(this) m'.(this). -Fixpoint lt_list (m m' : list (X.t * D.t)) {struct m} : Prop := - match m, m' with +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 + | (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') @@ -1209,9 +1209,9 @@ Proof. destruct a; unfold equal; simpl; intuition. destruct a as (x,e). destruct p as (x',e'). - unfold equal; simpl. + unfold equal; simpl. destruct (X.compare x x'); simpl; intuition. - unfold cmp at 1. + unfold cmp at 1. MD.elim_comp; clear H; simpl. inversion_clear Hl. inversion_clear Hl'. @@ -1258,7 +1258,7 @@ Qed. Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. Proof. - intros (m,Hm); induction m; + intros (m,Hm); induction m; intros (m', Hm'); destruct m'; unfold eq; simpl; try destruct a as (x,e); try destruct p as (x',e'); auto. destruct (X.compare x x'); MapS.Raw.MX.elim_comp; intuition. @@ -1267,17 +1267,16 @@ Proof. 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'); +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold eq; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare x x'); - destruct (X.compare x' x''); - MapS.Raw.MX.elim_comp. - intuition. + destruct (X.compare x x'); + destruct (X.compare x' x''); + MapS.Raw.MX.elim_comp; intuition. apply D.eq_trans with e'; auto. inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. apply (IHm1 H1 (Build_slist H6) (Build_slist H8)); intuition. @@ -1285,16 +1284,15 @@ 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'); + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold lt; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); try destruct p0 as (x'',e''); try contradiction; auto. - destruct (X.compare x x'); - destruct (X.compare x' x''); - MapS.Raw.MX.elim_comp; auto. - intuition. + destruct (X.compare x x'); + destruct (X.compare x' x''); + MapS.Raw.MX.elim_comp; intuition. left; apply D.lt_trans with e'; auto. left; apply lt_eq with e'; auto. left; apply eq_lt with e'; auto. @@ -1307,9 +1305,9 @@ Qed. Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; - try destruct a as (x,e); + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; + try destruct a as (x,e); try destruct p as (x',e'); try contradiction; auto. destruct (X.compare x x'); auto. intuition. @@ -1322,20 +1320,20 @@ Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto. Definition compare : forall m1 m2, Compare lt eq m1 m2. Proof. - intros (m1,Hm1); induction m1; - intros (m2, Hm2); destruct m2; + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; [ apply EQ | apply LT | apply GT | ]; cmp_solve. - destruct a as (x,e); destruct p as (x',e'). - destruct (X.compare x x'); + destruct a as (x,e); destruct p as (x',e'). + destruct (X.compare x x'); [ apply LT | | apply GT ]; cmp_solve. - destruct (D.compare e e'); + destruct (D.compare e e'); [ apply LT | | apply GT ]; cmp_solve. assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1). inversion_clear Hm1; auto. assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2). inversion_clear Hm2; auto. - destruct (IHm1 Hm11 (Build_slist Hm22)); + destruct (IHm1 Hm11 (Build_slist Hm22)); [ apply LT | apply EQ | apply GT ]; cmp_solve. Qed. -End Make_ord. +End Make_ord. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index 7fbc3d47..7c5a4fa1 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -6,131 +6,36 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre - * Institution: LRI, CNRS UMR 8623 - Université Paris Sud - * 91405 Orsay, France *) +(* $Id$ *) -(* $Id: FMapPositive.v 11699 2008-12-18 11:49:08Z letouzey $ *) +(** * FMapPositive : an implementation of FMapInterface for [positive] keys. *) -Require Import Bool. -Require Import ZArith. -Require Import OrderedType. -Require Import OrderedTypeEx. -Require Import FMapInterface. +Require Import Bool ZArith OrderedType OrderedTypeEx FMapInterface. Set Implicit Arguments. - Open Local Scope positive_scope. -(** * An implementation of [FMapInterface.S] for positive keys. *) +Local Unset Elimination Schemes. +Local Unset Case Analysis Schemes. -(** This file is an adaptation to the [FMap] framework of a work by +(** This file is an adaptation to the [FMap] framework of a work by Xavier Leroy and Sandrine Blazy (used for building certified compilers). - Keys are of type [positive], and maps are binary trees: the sequence + Keys are of type [positive], and maps are binary trees: the sequence of binary digits of a positive number corresponds to a path in such a tree. - This is quite similar to the [IntMap] library, except that no path compression - is implemented, and that the current file is simple enough to be + This is quite similar to the [IntMap] library, except that no path + compression is implemented, and that the current file is simple enough to be self-contained. *) -(** Even if [positive] can be seen as an ordered type with respect to the - usual order (see [OrderedTypeEx]), we use here a lexicographic order - over bits, which is more natural here (lower bits are considered first). *) - -Module PositiveOrderedTypeBits <: UsualOrderedType. - Definition t:=positive. - Definition eq:=@eq positive. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - - Fixpoint bits_lt (p q:positive) { struct p } : 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_trans : forall x y z : positive, bits_lt x y -> bits_lt y z -> bits_lt x z. - Proof. - induction x. - induction y; destruct z; simpl; eauto; intuition. - induction y; destruct z; simpl; eauto; intuition. - induction y; destruct z; simpl; eauto; intuition. - Qed. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. - exact bits_lt_trans. - Qed. - - Lemma bits_lt_antirefl : forall x : positive, ~ bits_lt x x. - Proof. - induction x; simpl; auto. - Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros; intro. - rewrite <- H0 in H; clear H0 y. - unfold lt in H. - exact (bits_lt_antirefl x H). - Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - Proof. - induction x; destruct y. - (* I I *) - destruct (IHx y). - apply LT; auto. - apply EQ; rewrite e; red; auto. - apply GT; auto. - (* I O *) - apply GT; simpl; auto. - (* I H *) - apply GT; simpl; auto. - (* O I *) - apply LT; simpl; auto. - (* O O *) - destruct (IHx y). - apply LT; auto. - apply EQ; rewrite e; red; auto. - apply GT; auto. - (* O H *) - apply LT; simpl; auto. - (* H I *) - apply LT; simpl; auto. - (* H O *) - apply GT; simpl; auto. - (* H H *) - apply EQ; red; auto. - Qed. - - Lemma eq_dec (x y: positive): {x = y} + {x <> y}. - Proof. - intros. case_eq ((x ?= y) Eq); intros. - left. apply Pcompare_Eq_eq; auto. - right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate. - right. red. intro. subst y. rewrite (Pcompare_refl x) in H. discriminate. - Qed. +(** First, some stuff about [positive] *) -End PositiveOrderedTypeBits. - -(** Other positive stuff *) - -Fixpoint append (i j : positive) {struct i} : positive := +Fixpoint append (i j : positive) : positive := match i with | xH => j | xI ii => xI (append ii j) | xO ii => xO (append ii j) end. -Lemma append_assoc_0 : +Lemma append_assoc_0 : forall (i j : positive), append i (xO j) = append (append i (xO xH)) j. Proof. induction i; intros; destruct j; simpl; @@ -140,7 +45,7 @@ Proof. auto. Qed. -Lemma append_assoc_1 : +Lemma append_assoc_1 : forall (i j : positive), append i (xI j) = append (append i (xI xH)) j. Proof. induction i; intros; destruct j; simpl; @@ -159,7 +64,7 @@ Lemma append_neutral_l : forall (i : positive), append xH i = i. Proof. simpl; auto. Qed. - + (** The module of maps over positive keys *) @@ -174,6 +79,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. | Leaf : tree A | Node : tree A -> option A -> tree A -> tree A. + Scheme tree_ind := Induction for tree Sort Prop. + Definition t := tree. Section A. @@ -182,15 +89,15 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Implicit Arguments Leaf [A]. Definition empty : t A := Leaf. - - Fixpoint is_empty (m : t A) {struct m} : bool := - match m with + + 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 : positive) (m : t A) {struct i} : option A := + Fixpoint find (i : positive) (m : t A) : option A := match m with | Leaf => None | Node l o r => @@ -201,7 +108,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint mem (i : positive) (m : t A) {struct i} : bool := + Fixpoint mem (i : positive) (m : t A) : bool := match m with | Leaf => false | Node l o r => @@ -212,7 +119,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint add (i : positive) (v : A) (m : t A) {struct i} : t A := + Fixpoint add (i : positive) (v : A) (m : t A) : t A := match m with | Leaf => match i with @@ -228,7 +135,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. end end. - Fixpoint remove (i : positive) (m : t A) {struct i} : t A := + Fixpoint remove (i : positive) (m : t A) : t A := match i with | xH => match m with @@ -260,8 +167,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. (** [elements] *) - Fixpoint xelements (m : t A) (i : positive) {struct m} - : list (positive * A) := + Fixpoint xelements (m : t A) (i : positive) : list (positive * A) := match m with | Leaf => nil | Node l None r => @@ -279,8 +185,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. (** [cardinal] *) Fixpoint cardinal (m : t A) : nat := - match m with - | Leaf => 0%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. @@ -387,7 +293,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. exact (xelements_correct m i xH H). Qed. - Fixpoint xfind (i j : positive) (m : t A) {struct j} : option A := + Fixpoint xfind (i j : positive) (m : t A) : option A := match i, j with | _, xH => find i m | xO ii, xO jj => xfind ii jj m @@ -400,7 +306,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. xfind i (append j (xO xH)) m1 = Some v -> xfind i j (Node m1 o m2) = Some v. Proof. induction j; intros; destruct i; simpl; simpl in H; auto; try congruence. - destruct i; congruence. + destruct i; simpl in *; auto. Qed. Lemma xelements_ii : @@ -565,7 +471,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. exact (xelements_complete i xH m v H). Qed. - Lemma cardinal_1 : + Lemma cardinal_1 : forall (m: t A), cardinal m = length (elements m). Proof. unfold elements. @@ -584,13 +490,17 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Definition Empty m := forall (a : positive)(e:A) , ~ MapsTo a e m. Definition eq_key (p p':positive*A) := E.eq (fst p) (fst p'). - - Definition eq_key_elt (p p':positive*A) := + + Definition eq_key_elt (p p':positive*A) := E.eq (fst p) (fst p') /\ (snd p) = (snd p'). Definition lt_key (p p':positive*A) := E.lt (fst p) (fst p'). - Lemma mem_find : + Global Instance eqk_equiv : Equivalence eq_key. + Global Instance eqke_equiv : Equivalence eq_key_elt. + Global Instance ltk_strorder : StrictOrder lt_key. + + Lemma mem_find : forall m x, mem x m = match find x m with None => false | _ => true end. Proof. induction m; destruct x; simpl; auto. @@ -625,7 +535,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl; generalize H0; rewrite Empty_alt; auto. Qed. - Section FMapSpec. + Section FMapSpec. Lemma mem_1 : forall m x, In x m -> mem x m = true. Proof. @@ -633,7 +543,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. destruct 1 as (e0,H0); rewrite H0; auto. Qed. - Lemma mem_2 : forall m x, mem x m = true -> In x m. + Lemma mem_2 : forall m x, mem x m = true -> In x m. Proof. unfold In, MapsTo; intros m x; rewrite mem_find. destruct (find x m). @@ -659,7 +569,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. rewrite Empty_alt; apply gempty. Qed. - Lemma is_empty_1 : Empty m -> is_empty m = true. + Lemma is_empty_1 : Empty m -> is_empty m = true. Proof. induction m; simpl; auto. rewrite Empty_Node. @@ -699,10 +609,11 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma remove_1 : E.eq x y -> ~ In y (remove x m). - Proof. + Proof. intros; intro. generalize (mem_1 H0). rewrite mem_find. + red in H. rewrite H. rewrite grs. intros; discriminate. @@ -715,15 +626,15 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. - Proof. + Proof. unfold MapsTo. destruct (E.eq_dec x y). subst. rewrite grs; intros; discriminate. rewrite gro; auto. Qed. - - Lemma elements_1 : + + Lemma elements_1 : MapsTo x e m -> InA eq_key_elt (x,e) (elements m). Proof. unfold MapsTo. @@ -735,7 +646,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. apply elements_correct; auto. Qed. - Lemma elements_2 : + Lemma elements_2 : InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. unfold MapsTo. @@ -745,7 +656,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. apply elements_complete; auto. Qed. - Lemma xelements_bits_lt_1 : forall p p0 q m v, + Lemma xelements_bits_lt_1 : forall p p0 q m v, List.In (p0,v) (xelements m (append p (xO q))) -> E.bits_lt p0 p. Proof. intros. @@ -754,7 +665,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. induction p; destruct p0; simpl; intros; eauto; try discriminate. Qed. - Lemma xelements_bits_lt_2 : forall p p0 q m v, + Lemma xelements_bits_lt_2 : forall p p0 q m v, List.In (p0,v) (xelements m (append p (xI q))) -> E.bits_lt p p0. Proof. intros. @@ -769,8 +680,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl; auto. destruct o; simpl; intros. (* Some *) - apply (SortA_app (eqA:=eq_key_elt)); auto. - compute; intuition. + apply (SortA_app (eqA:=eq_key_elt)); auto with *. constructor; auto. apply In_InfA; intros. destruct y0. @@ -789,8 +699,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. eapply xelements_bits_lt_1; eauto. eapply xelements_bits_lt_2; eauto. (* None *) - apply (SortA_app (eqA:=eq_key_elt)); auto. - compute; intuition. + apply (SortA_app (eqA:=eq_key_elt)); auto with *. intros x0 y0. do 2 rewrite InA_alt. intros (y1,(Hy1,H)) (y2,(Hy2,H0)). @@ -802,7 +711,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. eapply xelements_bits_lt_2; eauto. Qed. - Lemma elements_3 : sort lt_key (elements m). + Lemma elements_3 : sort lt_key (elements m). Proof. unfold elements. apply xelements_sort; auto. @@ -817,14 +726,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End FMapSpec. (** [map] and [mapi] *) - + Variable B : Type. Section Mapi. Variable f : positive -> A -> B. - Fixpoint xmapi (m : t A) (i : positive) {struct m} : t B := + Fixpoint xmapi (m : t A) (i : positive) : t B := match m with | Leaf => @Leaf B | Node l o r => Node (xmapi l (append i (xO xH))) @@ -861,9 +770,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. rewrite append_neutral_l; auto. Qed. - Lemma mapi_1 : - forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> + Lemma mapi_1 : + forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros. @@ -876,8 +785,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl; auto. Qed. - Lemma mapi_2 : - forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'), + Lemma mapi_2 : + forall (elt elt':Type)(m: t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. intros. @@ -890,14 +799,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. simpl in *; discriminate. Qed. - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros; unfold map. destruct (mapi_1 (fun _ => f) H); intuition. Qed. - - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. intros; unfold map in *; eapply mapi_2; eauto. @@ -906,10 +815,10 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Section map2. Variable A B C : Type. Variable f : option A -> option B -> option C. - + Implicit Arguments Leaf [A]. - Fixpoint xmap2_l (m : t A) {struct m} : t C := + Fixpoint xmap2_l (m : t A) : t C := match m with | Leaf => Leaf | Node l o r => Node (xmap2_l l) (f o None) (xmap2_l r) @@ -921,7 +830,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. induction i; intros; destruct m; simpl; auto. Qed. - Fixpoint xmap2_r (m : t B) {struct m} : t C := + Fixpoint xmap2_r (m : t B) : t C := match m with | Leaf => Leaf | Node l o r => Node (xmap2_r l) (f None o) (xmap2_r r) @@ -933,7 +842,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. induction i; intros; destruct m; simpl; auto. Qed. - Fixpoint _map2 (m1 : t A)(m2 : t B) {struct m1} : t C := + Fixpoint _map2 (m1 : t A)(m2 : t B) : t C := match m1 with | Leaf => xmap2_r m2 | Node l1 o1 r1 => @@ -953,14 +862,14 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. End map2. - Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') := + Definition map2 (elt elt' elt'':Type)(f:option elt->option elt'->option elt'') := _map2 (fun o1 o2 => match o1,o2 with None,None => None | _, _ => f o1 o2 end). Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. intros. unfold map2. rewrite gmap2; auto. @@ -973,7 +882,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. Proof. intros. @@ -1031,12 +940,12 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. rewrite xfoldi_1; reflexivity. Qed. - Fixpoint equal (A:Type)(cmp : A -> A -> bool)(m1 m2 : t A) {struct m1} : bool := - match m1, m2 with + 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 + | Node l1 o1 r1, Node l2 o2 r2 => + (match o1, o2 with | None, None => true | Some v1, Some v2 => cmp v1 v2 | _, _ => false @@ -1044,19 +953,19 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. && equal cmp l1 l2 && equal cmp r1 r2 end. - Definition Equal (A:Type)(m m':t A) := + 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 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. + 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. + destruct 1. simpl. apply is_empty_1. red; red; intros. @@ -1068,7 +977,7 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. (* m = Node *) destruct m'. (* m' = Leaf *) - destruct 1. + destruct 1. simpl. destruct o. assert (In xH (Leaf A)). @@ -1105,9 +1014,9 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. 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. + 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. @@ -1181,7 +1090,7 @@ Module PositiveMapAdditionalFacts. rewrite (IHi m2 v H); congruence. rewrite (IHi m1 v H); congruence. Qed. - + Lemma xmap2_lr : forall (A B : Type)(f g: option A -> option A -> option B)(m : t A), (forall (i j : option A), f i j = g j i) -> @@ -1209,7 +1118,7 @@ Module PositiveMapAdditionalFacts. auto. rewrite IHm1_1. rewrite IHm1_2. - auto. + auto. Qed. End PositiveMapAdditionalFacts. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index be09e41a..38ed172b 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -6,9 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMapWeakList.v 10616 2008-03-04 17:33:35Z letouzey $ *) +(* $Id$ *) -(** * Finite map library *) +(** * Finite map library *) (** This file proposes an implementation of the non-dependant interface [FMapInterface.WS] using lists of pairs, unordered but without redundancy. *) @@ -29,7 +29,7 @@ Section Elt. Variable elt : Type. -Notation eqk := (eqk (elt:=elt)). +Notation eqk := (eqk (elt:=elt)). Notation eqke := (eqke (elt:=elt)). Notation MapsTo := (MapsTo (elt:=elt)). Notation In := (In (elt:=elt)). @@ -52,7 +52,7 @@ Qed. Hint Resolve empty_1. Lemma empty_NoDup : NoDupA empty. -Proof. +Proof. unfold empty; auto. Qed. @@ -60,7 +60,7 @@ Qed. Definition is_empty (l : t elt) : bool := if l then true else false. -Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. +Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. Proof. unfold Empty, PX.MapsTo. intros m. @@ -88,7 +88,7 @@ Function mem (k : key) (s : t elt) {struct s} : bool := Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true. Proof. - intros m Hm x; generalize Hm; clear Hm. + intros m Hm x; generalize Hm; clear Hm. functional induction (mem x m);intros NoDup belong1;trivial. inversion belong1. inversion H. inversion_clear NoDup. @@ -98,13 +98,13 @@ Proof. contradiction. apply IHb; auto. exists x0; auto. -Qed. +Qed. -Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. +Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. Proof. intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. functional induction (mem x m); intros NoDup hyp; try discriminate. - exists _x; auto. + exists _x; auto. inversion_clear NoDup. destruct IHb; auto. exists x0; auto. @@ -124,8 +124,8 @@ Proof. functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto. Qed. -Lemma find_1 : forall m (Hm:NoDupA m) x e, - MapsTo x e m -> find x m = Some e. +Lemma find_1 : forall m (Hm:NoDupA m) x e, + MapsTo x e m -> find x m = Some e. Proof. intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo. functional induction (find x m);simpl; subst; try clear H_eq_1. @@ -142,7 +142,7 @@ Qed. (* Not part of the exported specifications, used later for [combine]. *) -Lemma find_eq : forall m (Hm:NoDupA m) x x', +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. @@ -167,7 +167,7 @@ Proof. functional induction (add x e m);simpl;auto. Qed. -Lemma add_2 : forall m x y e e', +Lemma add_2 : forall m x y e e', ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). Proof. intros m x y e e'; generalize y e; clear y e; unfold PX.MapsTo. @@ -178,7 +178,7 @@ Proof. auto. intros y' e'' eqky'; inversion_clear 1; intuition. Qed. - + Lemma add_3 : forall m x y e e', ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. Proof. @@ -189,14 +189,14 @@ Proof. inversion_clear 2; auto. Qed. -Lemma add_3' : forall m x y e e', - ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. +Lemma add_3' : forall m x y e e', + ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. Proof. intros m x y e e'. generalize y e; clear y e. functional induction (add x e' m);simpl;auto. inversion_clear 2. compute in H1; elim H; auto. - inversion H1. + inversion H1. constructor 2; inversion_clear H0; auto. compute in H1; elim H; auto. inversion_clear 2; auto. @@ -218,7 +218,7 @@ Qed. (* Not part of the exported specifications, used later for [combine]. *) -Lemma add_eq : forall m (Hm:NoDupA m) x a e, +Lemma add_eq : forall m (Hm:NoDupA m) x a e, X.eq x a -> find x (add a e m) = Some e. Proof. intros. @@ -227,7 +227,7 @@ Proof. apply add_1; auto. Qed. -Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, +Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, ~X.eq x a -> find x (add a e m) = find x m. Proof. intros. @@ -250,7 +250,7 @@ Function remove (k : key) (s : t elt) {struct s} : t elt := match s with | nil => nil | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l - end. + end. Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m). Proof. @@ -265,7 +265,7 @@ Proof. destruct H0 as (e,H2); unfold PX.MapsTo in H2. apply InA_eqk with (y,e); auto. compute; apply X.eq_trans with x; auto. - + intro H2. destruct H2 as (e,H2); inversion_clear H2. compute in H0; destruct H0. @@ -274,8 +274,8 @@ Proof. elim (IHt0 H2 H). exists e; auto. Qed. - -Lemma remove_2 : forall m (Hm:NoDupA m) x y e, + +Lemma remove_2 : forall m (Hm:NoDupA m) x y e, ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. @@ -283,11 +283,11 @@ Proof. inversion_clear 3; auto. compute in H1; destruct H1. elim H; apply X.eq_trans with k'; auto. - + inversion_clear 1; inversion_clear 2; auto. Qed. -Lemma remove_3 : forall m (Hm:NoDupA m) x y e, +Lemma remove_3 : forall m (Hm:NoDupA m) x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. @@ -295,7 +295,7 @@ Proof. do 2 inversion_clear 1; auto. Qed. -Lemma remove_3' : forall m (Hm:NoDupA m) x y e, +Lemma remove_3' : forall m (Hm:NoDupA m) x y e, InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. Proof. intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. @@ -313,7 +313,7 @@ Proof. simpl; case (X.eq_dec x x'); auto. constructor; auto. contradict H; apply remove_3' with x; auto. -Qed. +Qed. (** * [elements] *) @@ -325,12 +325,12 @@ Proof. Qed. Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. -Proof. +Proof. auto. Qed. -Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). -Proof. +Lemma elements_3w : forall m (Hm:NoDupA m), NoDupA (elements m). +Proof. auto. Qed. @@ -344,34 +344,34 @@ Function fold (A:Type)(f:key->elt->A->A)(m:t elt) (acc : A) {struct m} : A := Lemma fold_1 : forall m (A:Type)(i:A)(f:key->elt->A->A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. -Proof. +Proof. intros; functional induction (@fold A f m i); auto. Qed. (** * [equal] *) -Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := - match find k m' with +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 submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := + fold (fun k e b => andb (check cmp k e m') b) m true. + Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). -Definition Submap cmp m m' := - (forall k, In k m -> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). +Definition Submap cmp m m' := + (forall k, In k m -> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Definition Equivb cmp m m' := - (forall k, In k m <-> In k m') /\ - (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). +Definition Equivb cmp m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). -Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Submap cmp m m' -> submap cmp m m' = true. +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. @@ -390,9 +390,9 @@ Proof. destruct H5 as (e'',H5); exists e''; auto. apply H0 with k; auto. Qed. - -Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - submap cmp m m' = true -> Submap cmp m m'. + +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. @@ -400,7 +400,7 @@ Proof. intuition. destruct H0; inversion H0. inversion H0. - + destruct a; simpl; intros. inversion_clear Hm. rewrite andb_b_true in H. @@ -414,7 +414,7 @@ Proof. 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]; + 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. @@ -432,15 +432,15 @@ Qed. (** Specification of [equal] *) -Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, - Equivb cmp m m' -> equal cmp m m' = true. -Proof. +Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + Equivb cmp m m' -> equal cmp m m' = true. +Proof. unfold Equivb, equal. intuition. apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. Qed. -Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, +Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. unfold Equivb, equal. @@ -449,43 +449,43 @@ Proof. generalize (submap_2 Hm Hm' H0). generalize (submap_2 Hm' Hm H1). firstorder. -Qed. +Qed. Variable elt':Type. (** * [map] and [mapi] *) - -Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : t elt' := + +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) {struct m} : t elt' := +Fixpoint mapi (f: key -> elt -> elt') (m:t elt) : t elt' := match m with | nil => nil | (k,e)::m' => (k,f k e) :: mapi f m' end. End Elt. -Section Elt2. -(* A new section is necessary for previous definitions to work +Section Elt2. +(* A new section is necessary for previous definitions to work with different [elt], especially [MapsTo]... *) - + Variable elt elt' : Type. (** Specification of [map] *) -Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), +Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros m x e f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. - + destruct a as (x',e'). - simpl. + simpl. inversion_clear 1. constructor 1. unfold eqke in *; simpl in *; intuition congruence. @@ -493,15 +493,15 @@ Proof. unfold MapsTo in *; auto. Qed. -Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), +Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), In x (map f m) -> In x m. Proof. - intros m x f. + intros m x f. (* functional induction map elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. - + destruct a as (x',e). intros hyp. inversion hyp. clear hyp. @@ -514,9 +514,9 @@ Proof. constructor 2; auto. Qed. -Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), +Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), NoDupA (@eqk elt') (map f m). -Proof. +Proof. induction m; simpl; auto. intros. destruct a as (x',e'). @@ -524,25 +524,25 @@ Proof. constructor; auto. contradict H. (* il faut un map_1 avec eqk au lieu de eqke *) - clear IHm H0. + clear IHm H0. induction m; simpl in *; auto. inversion H. destruct a; inversion H; auto. -Qed. - +Qed. + (** Specification of [mapi] *) -Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), - MapsTo x e m -> +Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros m x e f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m. inversion 1. - + destruct a as (x',e'). - simpl. + simpl. inversion_clear 1. exists x'. destruct H0; simpl in *. @@ -551,17 +551,17 @@ Proof. unfold eqke in *; simpl in *; intuition congruence. destruct IHm as (y, hyp); auto. exists y; intuition. -Qed. +Qed. -Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), +Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), In x (mapi f m) -> In x m. Proof. - intros m x f. + intros m x f. (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) induction m; simpl. intros (e,abs). inversion abs. - + destruct a as (x',e). intros hyp. inversion hyp. clear hyp. @@ -574,7 +574,7 @@ Proof. constructor 2; auto. Qed. -Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), +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. @@ -589,30 +589,30 @@ Proof. destruct a; inversion_clear H; auto. Qed. -End Elt2. +End Elt2. Section Elt3. Variable elt elt' elt'' : Type. Notation oee' := (option elt * option elt')%type. - + Definition combine_l (m:t elt)(m':t elt') : t oee' := - mapi (fun k e => (Some e, find k m')) m. + mapi (fun k e => (Some e, find k m')) m. Definition combine_r (m:t elt)(m':t elt') : t oee' := - mapi (fun k e' => (find k m, Some e')) m'. + mapi (fun k e' => (find k m, Some e')) m'. -Definition fold_right_pair (A B C:Type)(f:A->B->C->C)(l:list (A*B))(i:C) := +Definition fold_right_pair (A B C:Type)(f:A->B->C->C)(l:list (A*B))(i:C) := List.fold_right (fun p => f (fst p) (snd p)) i l. -Definition combine (m:t elt)(m':t elt') : t oee' := - let l := combine_l m m' in - let r := combine_r m m' in +Definition combine (m:t elt)(m':t elt') : t oee' := + let l := combine_l m m' in + let r := combine_r m m' in fold_right_pair (add (elt:=oee')) l r. -Lemma fold_right_pair_NoDup : - forall l r (Hl: NoDupA (eqk (elt:=oee')) l) - (Hl: NoDupA (eqk (elt:=oee')) r), +Lemma fold_right_pair_NoDup : + forall l r (Hl: NoDupA (eqk (elt:=oee')) l) + (Hl: NoDupA (eqk (elt:=oee')) r), NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) l r). Proof. induction l; simpl; auto. @@ -622,8 +622,8 @@ Proof. Qed. Hint Resolve fold_right_pair_NoDup. -Lemma combine_NoDup : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), +Lemma combine_NoDup : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), NoDupA (@eqk oee') (combine m m'). Proof. unfold combine, combine_r, combine_l. @@ -637,21 +637,21 @@ Proof. auto. Qed. -Definition at_least_left (o:option elt)(o':option elt') := - match o with - | None => None +Definition at_least_left (o:option elt)(o':option elt') := + match o with + | None => None | _ => Some (o,o') end. -Definition at_least_right (o:option elt)(o':option elt') := - match o' with - | None => None +Definition at_least_right (o:option elt)(o':option elt') := + match o' with + | None => None | _ => Some (o,o') end. -Lemma combine_l_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine_l m m') = at_least_left (find x m) (find x m'). +Lemma combine_l_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine_l m m') = at_least_left (find x m) (find x m'). Proof. unfold combine_l. intros. @@ -668,9 +668,9 @@ Proof. rewrite (find_1 Hm H1) in H; discriminate. Qed. -Lemma combine_r_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine_r m m') = at_least_right (find x m) (find x m'). +Lemma combine_r_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine_r m m') = at_least_right (find x m) (find x m'). Proof. unfold combine_r. intros. @@ -687,15 +687,15 @@ Proof. rewrite (find_1 Hm' H1) in H; discriminate. Qed. -Definition at_least_one (o:option elt)(o':option elt') := - match o, o' with - | None, None => None +Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None | _, _ => Some (o,o') end. -Lemma combine_1 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (combine m m') = at_least_one (find x m) (find x m'). +Lemma combine_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine m m') = at_least_one (find x m) (find x m'). Proof. unfold combine. intros. @@ -726,19 +726,19 @@ Qed. Variable f : option elt -> option elt' -> option elt''. -Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := +Definition option_cons (A:Type)(k:key)(o:option A)(l:list (key*A)) := match o with | Some e => (k,e)::l | None => l end. -Definition map2 m m' := - let m0 : t oee' := combine m m' in - let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in +Definition map2 m m' := + let m0 : t oee' := combine m m' in + let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in fold_right_pair (option_cons (A:=elt'')) m1 nil. -Lemma map2_NoDup : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), +Lemma map2_NoDup : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), NoDupA (@eqk elt'') (map2 m m'). Proof. intros. @@ -747,7 +747,7 @@ Proof. set (l0:=combine m m') in *; clearbody l0. set (f':= fun p : oee' => f (fst p) (snd p)). assert (H1:=map_NoDup (elt' := option elt'') H0 f'). - set (l1:=map f' l0) in *; clearbody l1. + set (l1:=map f' l0) in *; clearbody l1. clear f' f H0 l0 Hm Hm' m m'. induction l1. simpl; auto. @@ -763,15 +763,15 @@ Proof. inversion_clear H; auto. Qed. -Definition at_least_one_then_f (o:option elt)(o':option elt') := - match o, o' with - | None, None => None +Definition at_least_one_then_f (o:option elt)(o':option elt') := + match o, o' with + | None, None => None | _, _ => f o o' end. -Lemma map2_0 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). +Lemma map2_0 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). Proof. intros. unfold map2. @@ -779,7 +779,7 @@ Proof. assert (H2:=combine_NoDup Hm Hm'). set (f':= fun p : oee' => f (fst p) (snd p)). set (m0 := combine m m') in *; clearbody m0. - set (o:=find x m) in *; clearbody o. + set (o:=find x m) in *; clearbody o. set (o':=find x m') in *; clearbody o'. clear Hm Hm' m m'. generalize H; clear H. @@ -795,14 +795,14 @@ Proof. destruct o; destruct o'; simpl in *; inversion_clear H; auto. rewrite H2. unfold f'; simpl. - destruct (f oo oo'); simpl. + destruct (f oo oo'); simpl. destruct (X.eq_dec x k); try contradict n; auto. destruct (IHm0 H1) as (_,H4); apply H4; auto. case_eq (find x m0); intros; auto. elim H0. apply InA_eqk with (x,p); auto. apply InA_eqke_eqk. - exact (find_2 H3). + exact (find_2 H3). (* k < x *) unfold f'; simpl. destruct (f oo oo'); simpl. @@ -826,10 +826,10 @@ Proof. Qed. (** Specification of [map2] *) -Lemma map2_1 : +Lemma map2_1 : forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - In x m \/ In x m' -> - find x (map2 m m') = f (find x m) (find x m'). + In x m \/ In x m' -> + find x (map2 m m') = f (find x m) (find x m'). Proof. intros. rewrite map2_0; auto. @@ -839,10 +839,10 @@ Proof. rewrite (find_1 Hm' H). destruct (find x m); simpl; auto. Qed. - -Lemma map2_2 : - forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), - In x (map2 m m') -> In x m \/ In x m'. + +Lemma map2_2 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + In x (map2 m m') -> In x m \/ In x m'. Proof. intros. destruct H as (e,H). @@ -850,9 +850,9 @@ Proof. rewrite (find_1 (map2_NoDup Hm Hm') H). generalize (@find_2 _ m x). generalize (@find_2 _ m' x). - destruct (find x m); + destruct (find x m); destruct (find x m'); simpl; intros. - left; exists e0; auto. + left; exists e0; auto. left; exists e0; auto. right; exists e0; auto. discriminate. @@ -863,31 +863,31 @@ End Raw. Module Make (X: DecidableType) <: WS with Module E:=X. - Module Raw := Raw X. + Module Raw := Raw X. Module E := X. - Definition key := E.t. + Definition key := E.t. - Record slist (elt:Type) := + Record slist (elt:Type) := {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. - Definition t (elt:Type) := slist elt. + Definition t (elt:Type) := slist elt. -Section Elt. - Variable elt elt' elt'':Type. +Section Elt. + Variable elt elt' elt'':Type. Implicit Types m : t elt. - Implicit Types x y : key. + Implicit Types x y : key. Implicit Types e : elt. Definition empty : t elt := Build_slist (Raw.empty_NoDup elt). Definition is_empty m : bool := Raw.is_empty m.(this). Definition add x e m : t elt := Build_slist (Raw.add_NoDup m.(NoDup) x e). Definition find x m : option elt := Raw.find x m.(this). - Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x). + Definition remove x m : t elt := Build_slist (Raw.remove_NoDup m.(NoDup) x). Definition mem x m : bool := Raw.mem x m.(this). Definition map f m : t elt' := Build_slist (Raw.map_NoDup m.(NoDup) f). Definition mapi (f:key->elt->elt') m : t elt' := Build_slist (Raw.mapi_NoDup m.(NoDup) f). - Definition map2 f m (m':t elt') : t elt'' := + Definition map2 f m (m':t elt') : t elt'' := Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)). Definition elements m : list (key*elt) := @Raw.elements elt m.(this). Definition cardinal m := length m.(this). @@ -898,9 +898,9 @@ Section Elt. Definition Empty m : Prop := Raw.Empty 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 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). Definition eq_key : (key*elt) -> (key*elt) -> Prop := @Raw.PX.eqk elt. @@ -936,7 +936,7 @@ Section Elt. Lemma remove_3 : forall m x y e, MapsTo y e (remove x m) -> MapsTo y e m. Proof. intros m; exact (@Raw.remove_3 elt m.(this) m.(NoDup)). Qed. - Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. + Lemma find_1 : forall m x e, MapsTo x e m -> find x m = Some e. Proof. intros m; exact (@Raw.find_1 elt m.(this) m.(NoDup)). Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m; exact (@Raw.find_2 elt m.(this)). Qed. @@ -945,32 +945,32 @@ Section Elt. Proof. intros m; exact (@Raw.elements_1 elt m.(this)). Qed. Lemma elements_2 : forall m x e, InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. Proof. intros m; exact (@Raw.elements_2 elt m.(this)). Qed. - Lemma elements_3w : forall m, NoDupA eq_key (elements m). + Lemma elements_3w : forall m, NoDupA eq_key (elements m). Proof. intros m; exact (@Raw.elements_3w elt m.(this) m.(NoDup)). Qed. - - Lemma cardinal_1 : forall m, cardinal m = length (elements m). + + Lemma cardinal_1 : forall m, cardinal m = length (elements m). Proof. intros; reflexivity. Qed. Lemma fold_1 : forall m (A : Type) (i : A) (f : key -> elt -> A -> A), fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. Proof. intros m; exact (@Raw.fold_1 elt m.(this)). Qed. - Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. + Lemma equal_1 : forall m m' cmp, Equivb cmp m m' -> equal cmp m m' = true. Proof. intros m m'; exact (@Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. Lemma equal_2 : forall m m' cmp, equal cmp m m' = true -> Equivb cmp m m'. Proof. intros m m'; exact (@Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup)). Qed. End Elt. - - Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), + + Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'), MapsTo x e m -> MapsTo x (f e) (map f m). Proof. intros elt elt' m; exact (@Raw.map_1 elt elt' m.(this)). Qed. - Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), - In x (map f m) -> In x m. + Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. Proof. intros elt elt' m; exact (@Raw.map_2 elt elt' m.(this)). Qed. Lemma mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt) - (f:key->elt->elt'), MapsTo x e m -> + (f:key->elt->elt'), MapsTo x e m -> exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. intros elt elt' m; exact (@Raw.mapi_1 elt elt' m.(this)). Qed. Lemma mapi_2 : forall (elt elt':Type)(m: t elt)(x:key) @@ -978,18 +978,18 @@ Section Elt. Proof. intros elt elt' m; exact (@Raw.mapi_2 elt elt' m.(this)). Qed. Lemma map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), - In x m \/ In x m' -> - find x (map2 f m m') = f (find x m) (find x m'). - Proof. - intros elt elt' elt'' m m' x f; + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + Proof. + intros elt elt' elt'' m m' x f; exact (@Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). Qed. Lemma map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt') - (x:key)(f:option elt->option elt'->option elt''), + (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. - Proof. - intros elt elt' elt'' m m' x f; + Proof. + intros elt elt' elt'' m m' x f; exact (@Raw.map2_2 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x). Qed. diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v index 75904202..6b110240 100644 --- a/theories/FSets/FMaps.v +++ b/theories/FSets/FMaps.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FMaps.v 10699 2008-03-19 20:56:43Z letouzey $ *) +(* $Id$ *) Require Export OrderedType OrderedTypeEx OrderedTypeAlt. diff --git a/theories/FSets/FSetAVL.v b/theories/FSets/FSetAVL.v index cc1c0a76..bc6c731f 100644 --- a/theories/FSets/FSetAVL.v +++ b/theories/FSets/FSetAVL.v @@ -1,3 +1,4 @@ +(* -*- coding: utf-8 -*- *) (***********************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) @@ -6,25 +7,20 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre - * Institution: LRI, CNRS UMR 8623 - Université Paris Sud - * 91405 Orsay, France *) +(* $Id$ *) -(* $Id: FSetAVL.v 11699 2008-12-18 11:49:08Z letouzey $ *) +(** * FSetAVL : Implementation of FSetInterface via AVL trees *) -(** * FSetAVL *) - -(** This module implements sets using AVL trees. +(** This module implements finite sets using AVL trees. It follows the implementation from Ocaml's standard library, - + All operations given here expect and produce well-balanced trees (in the ocaml sense: heigths of subtrees shouldn't differ by more than 2), and hence has low complexities (e.g. add is logarithmic in the size of the set). But proving these balancing preservations is in fact not necessary for ensuring correct operational behavior and hence fulfilling the FSet interface. As a consequence, - balancing results are not part of this file anymore, they can + balancing results are not part of this file anymore, they can now be found in [FSetFullAVL]. Four operations ([union], [subset], [compare] and [equal]) have @@ -37,2023 +33,20 @@ code after extraction. *) -Require Import FSetInterface FSetList ZArith Int. +Require Import FSetInterface ZArith Int. Set Implicit Arguments. Unset Strict Implicit. -(** Notations and helper lemma about pairs *) - -Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. -Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. - -(** * Raw - - Functor of pure functions + a posteriori proofs of invariant - preservation *) - -Module Raw (Import I:Int)(X:OrderedType). -Open Local Scope pair_scope. -Open Local Scope lazy_bool_scope. -Open Local Scope Int_scope. - -Definition elt := X.t. - -(** * Trees - - The fourth field of [Node] is the height of the tree *) - -Inductive tree := - | Leaf : tree - | Node : tree -> X.t -> tree -> int -> tree. - -Notation t := tree. - -(** * Basic functions on trees: height and cardinal *) - -Definition height (s : tree) : int := - match s with - | Leaf => 0 - | Node _ _ _ h => h - end. - -Fixpoint cardinal (s : tree) : nat := - match s with - | Leaf => 0%nat - | Node l _ r _ => S (cardinal l + cardinal r) - end. - -(** * Empty Set *) - -Definition empty := Leaf. - -(** * Emptyness test *) - -Definition is_empty s := - match s with Leaf => true | _ => false end. - -(** * Appartness *) - -(** The [mem] function is deciding appartness. It exploits the - binary search tree invariant to achieve logarithmic complexity. *) - -Fixpoint mem x s := - match s with - | Leaf => false - | Node l y r _ => match X.compare x y with - | LT _ => mem x l - | EQ _ => true - | GT _ => mem x r - end - end. - -(** * Singleton set *) - -Definition singleton x := Node Leaf x Leaf 1. - -(** * Helper functions *) - -(** [create l x r] creates a node, assuming [l] and [r] - to be balanced and [|height l - height r| <= 2]. *) - -Definition create l x r := - Node l x r (max (height l) (height r) + 1). - -(** [bal l x r] acts as [create], but performs one step of - rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) - -Definition assert_false := create. - -Definition bal l x r := - let hl := height l in - let hr := height r in - if gt_le_dec hl (hr+2) then - match l with - | Leaf => assert_false l x r - | Node ll lx lr _ => - if ge_lt_dec (height ll) (height lr) then - create ll lx (create lr x r) - else - match lr with - | Leaf => assert_false l x r - | Node lrl lrx lrr _ => - create (create ll lx lrl) lrx (create lrr x r) - end - end - else - if gt_le_dec hr (hl+2) then - match r with - | Leaf => assert_false l x r - | Node rl rx rr _ => - if ge_lt_dec (height rr) (height rl) then - create (create l x rl) rx rr - else - match rl with - | Leaf => assert_false l x r - | Node rll rlx rlr _ => - create (create l x rll) rlx (create rlr rx rr) - end - end - else - create l x r. - -(** * Insertion *) - -Fixpoint add x s := match s with - | Leaf => Node Leaf x Leaf 1 - | Node l y r h => - match X.compare x y with - | LT _ => bal (add x l) y r - | EQ _ => Node l y r h - | GT _ => bal l y (add x r) - end - end. - -(** * Join - - Same as [bal] but does not assume anything regarding heights - of [l] and [r]. -*) - -Fixpoint join l : elt -> t -> t := - match l with - | Leaf => add - | Node ll lx lr lh => fun x => - fix join_aux (r:t) : t := match r with - | Leaf => add x l - | Node rl rx rr rh => - if gt_le_dec lh (rh+2) then bal ll lx (join lr x r) - else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr - else create l x r - end - end. - -(** * Extraction of minimum element - - Morally, [remove_min] is to be applied to a non-empty tree - [t = Node l x r h]. Since we can't deal here with [assert false] - for [t=Leaf], we pre-unpack [t] (and forget about [h]). -*) - -Fixpoint remove_min l x r : t*elt := - match l with - | Leaf => (r,x) - | Node ll lx lr lh => - let (l',m) := remove_min ll lx lr in (bal l' x r, m) - end. - -(** * Merging two trees - - [merge t1 t2] builds the union of [t1] and [t2] assuming all elements - of [t1] to be smaller than all elements of [t2], and - [|height t1 - height t2| <= 2]. -*) - -Definition merge s1 s2 := match s1,s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node l2 x2 r2 h2 => - let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2' -end. - -(** * Deletion *) - -Fixpoint remove x s := match s with - | Leaf => Leaf - | Node l y r h => - match X.compare x y with - | LT _ => bal (remove x l) y r - | EQ _ => merge l r - | GT _ => bal l y (remove x r) - end - end. - -(** * Minimum element *) - -Fixpoint min_elt s := match s with - | Leaf => None - | Node Leaf y _ _ => Some y - | Node l _ _ _ => min_elt l -end. - -(** * Maximum element *) - -Fixpoint max_elt s := match s with - | Leaf => None - | Node _ y Leaf _ => Some y - | Node _ _ r _ => max_elt r -end. - -(** * Any element *) - -Definition choose := min_elt. - -(** * Concatenation - - Same as [merge] but does not assume anything about heights. -*) - -Definition concat s1 s2 := - match s1, s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | _, Node l2 x2 r2 _ => - let (s2',m) := remove_min l2 x2 r2 in - join s1 m s2' - end. - -(** * Splitting - - [split x s] returns a triple [(l, present, r)] where - - [l] is the set of elements of [s] that are [< x] - - [r] is the set of elements of [s] that are [> x] - - [present] is [true] if and only if [s] contains [x]. -*) - -Record triple := mktriple { t_left:t; t_in:bool; t_right:t }. -Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). -Notation "t #l" := (t_left t) (at level 9, format "t '#l'"). -Notation "t #b" := (t_in t) (at level 9, format "t '#b'"). -Notation "t #r" := (t_right t) (at level 9, format "t '#r'"). - -Fixpoint split x s : triple := match s with - | Leaf => << Leaf, false, Leaf >> - | Node l y r h => - match X.compare x y with - | LT _ => let (ll,b,rl) := split x l in << ll, b, join rl y r >> - | EQ _ => << l, true, r >> - | GT _ => let (rl,b,rr) := split x r in << join l y rl, b, rr >> - end - end. - -(** * Intersection *) - -Fixpoint inter s1 s2 := match s1, s2 with - | Leaf, _ => Leaf - | _, Leaf => Leaf - | Node l1 x1 r1 h1, _ => - let (l2',pres,r2') := split x1 s2 in - if pres then join (inter l1 l2') x1 (inter r1 r2') - else concat (inter l1 l2') (inter r1 r2') - end. - -(** * Difference *) - -Fixpoint diff s1 s2 := match s1, s2 with - | Leaf, _ => Leaf - | _, Leaf => s1 - | Node l1 x1 r1 h1, _ => - let (l2',pres,r2') := split x1 s2 in - if pres then concat (diff l1 l2') (diff r1 r2') - else join (diff l1 l2') x1 (diff r1 r2') -end. - -(** * Union *) - -(** In ocaml, heights of [s1] and [s2] are compared each time in order - to recursively perform the split on the smaller set. - Unfortunately, this leads to a non-structural algorithm. The - following code is a simplification of the ocaml version: no - comparison of heights. It might be slightly slower, but - experimentally all the tests I've made in ocaml have shown this - potential slowdown to be non-significant. Anyway, the exact code - of ocaml has also been formalized thanks to Function+measure, see - [ocaml_union] in [FSetFullAVL]. -*) - -Fixpoint union s1 s2 := - match s1, s2 with - | Leaf, _ => s2 - | _, Leaf => s1 - | Node l1 x1 r1 h1, _ => - let (l2',_,r2') := split x1 s2 in - join (union l1 l2') x1 (union r1 r2') - end. - -(** * Elements *) - -(** [elements_tree_aux acc t] catenates the elements of [t] in infix - order to the list [acc] *) - -Fixpoint elements_aux (acc : list X.t) (t : tree) : list X.t := - match t with - | Leaf => acc - | Node l x r _ => elements_aux (x :: elements_aux acc r) l - end. - -(** then [elements] is an instanciation with an empty [acc] *) - -Definition elements := elements_aux nil. - -(** * Filter *) - -Fixpoint filter_acc (f:elt->bool) acc s := match s with - | Leaf => acc - | Node l x r h => - filter_acc f (filter_acc f (if f x then add x acc else acc) l) r - end. - -Definition filter f := filter_acc f Leaf. - - -(** * Partition *) - -Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t := - match s with - | Leaf => acc - | Node l x r _ => - let (acct,accf) := acc in - partition_acc f - (partition_acc f - (if f x then (add x acct, accf) else (acct, add x accf)) l) r - end. - -Definition partition f := partition_acc f (Leaf,Leaf). - -(** * [for_all] and [exists] *) - -Fixpoint for_all (f:elt->bool) s := match s with - | Leaf => true - | Node l x r _ => f x &&& for_all f l &&& for_all f r -end. - -Fixpoint exists_ (f:elt->bool) s := match s with - | Leaf => false - | Node l x r _ => f x ||| exists_ f l ||| exists_ f r -end. - -(** * Fold *) - -Fixpoint fold (A : Type) (f : elt -> A -> A)(s : tree) : A -> A := - fun a => match s with - | Leaf => a - | Node l x r _ => fold f r (f x (fold f l a)) - end. -Implicit Arguments fold [A]. - - -(** * Subset *) - -(** In ocaml, recursive calls are made on "half-trees" such as - (Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these - non-structural calls, we propose here two specialized functions for - these situations. This version should be almost as efficient as - the one of ocaml (closures as arguments may slow things a bit), - it is simply less compact. The exact ocaml version has also been - formalized (thanks to Function+measure), see [ocaml_subset] in - [FSetFullAVL]. - *) - -Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool := - match s2 with - | Leaf => false - | Node l2 x2 r2 h2 => - match X.compare x1 x2 with - | EQ _ => subset_l1 l2 - | LT _ => subsetl subset_l1 x1 l2 - | GT _ => mem x1 r2 &&& subset_l1 s2 - end - end. - -Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool := - match s2 with - | Leaf => false - | Node l2 x2 r2 h2 => - match X.compare x1 x2 with - | EQ _ => subset_r1 r2 - | LT _ => mem x1 l2 &&& subset_r1 s2 - | GT _ => subsetr subset_r1 x1 r2 - end - end. - -Fixpoint subset s1 s2 : bool := match s1, s2 with - | Leaf, _ => true - | Node _ _ _ _, Leaf => false - | Node l1 x1 r1 h1, Node l2 x2 r2 h2 => - match X.compare x1 x2 with - | EQ _ => subset l1 l2 &&& subset r1 r2 - | LT _ => subsetl (subset l1) x1 l2 &&& subset r1 s2 - | GT _ => subsetr (subset r1) x1 r2 &&& subset l1 s2 - end - end. - -(** * A new comparison algorithm suggested by Xavier Leroy - - Transformation in C.P.S. suggested by Benjamin Grégoire. - The original ocaml code (with non-structural recursive calls) - has also been formalized (thanks to Function+measure), see - [ocaml_compare] in [FSetFullAVL]. The following code with - continuations computes dramatically faster in Coq, and - should be almost as efficient after extraction. -*) - -(** Enumeration of the elements of a tree *) - -Inductive enumeration := - | End : enumeration - | More : elt -> tree -> enumeration -> enumeration. - - -(** [cons t e] adds the elements of tree [t] on the head of - enumeration [e]. *) - -Fixpoint cons s e : enumeration := - match s with - | Leaf => e - | Node l x r h => cons l (More x r e) - end. - -(** One step of comparison of elements *) - -Definition compare_more x1 (cont:enumeration->comparison) e2 := - match e2 with - | End => Gt - | More x2 r2 e2 => - match X.compare x1 x2 with - | EQ _ => cont (cons r2 e2) - | LT _ => Lt - | GT _ => Gt - end - end. - -(** Comparison of left tree, middle element, then right tree *) - -Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := - match s1 with - | Leaf => cont e2 - | Node l1 x1 r1 _ => - compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2 - end. - -(** Initial continuation *) - -Definition compare_end e2 := - match e2 with End => Eq | _ => Lt end. - -(** The complete comparison *) - -Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End). - -(** * Equality test *) - -Definition equal s1 s2 : bool := - match compare s1 s2 with - | Eq => true - | _ => false - end. - - - - -(** * Invariants *) - -(** ** Occurrence in a tree *) - -Inductive In (x : elt) : tree -> Prop := - | IsRoot : forall l r h y, X.eq x y -> In x (Node l y r h) - | InLeft : forall l r h y, In x l -> In x (Node l y r h) - | InRight : forall l r h y, In x r -> In x (Node l y r h). - -(** ** Binary search trees *) - -(** [lt_tree x s]: all elements in [s] are smaller than [x] - (resp. greater for [gt_tree]) *) - -Definition lt_tree x s := forall y, In y s -> X.lt y x. -Definition gt_tree x s := forall y, In y s -> X.lt x y. - -(** [bst t] : [t] is a binary search tree *) - -Inductive bst : tree -> Prop := - | BSLeaf : bst Leaf - | BSNode : forall x l r h, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (Node l x r h). - - - - -(** * Some shortcuts *) - -Definition Equal s s' := forall a : elt, In a s <-> In a s'. -Definition Subset s s' := forall a : elt, In a s -> In a s'. -Definition Empty s := forall a : elt, ~ In a s. -Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. -Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - - -(** * Correctness proofs, isolated in a sub-module *) - -Module Proofs. - Module MX := OrderedTypeFacts X. - Module L := FSetList.Raw X. - -(** * Automation and dedicated tactics *) - -Hint Constructors In bst. -Hint Unfold lt_tree gt_tree. - -Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h) - "as" ident(s) := - set (s:=Node l x r h) in *; clearbody s; clear l x r h. - -(** 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 (Node _ _ _ _) |- _ => inversion_clear H; inv f - | H:f _ (Node _ _ _ _) |- _ => inversion_clear H; inv f - | _ => idtac - end. - -Ltac intuition_in := repeat progress (intuition; inv In). - -(** Helper tactic concerning order of elements. *) - -Ltac order := match goal with - | U: lt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order - | U: gt_tree _ ?s, V: In _ ?s |- _ => generalize (U _ V); clear U; order - | _ => MX.order -end. - - -(** * Basic results about [In], [lt_tree], [gt_tree], [height] *) - -(** [In] is compatible with [X.eq] *) - -Lemma In_1 : - forall s x y, X.eq x y -> In x s -> In y s. -Proof. - induction s; simpl; intuition_in; eauto. -Qed. -Hint Immediate In_1. - -Lemma In_node_iff : - forall l x r h y, - In y (Node l x r h) <-> In y l \/ X.eq y x \/ In y r. -Proof. - intuition_in. -Qed. - -(** Results about [lt_tree] and [gt_tree] *) - -Lemma lt_leaf : forall x : elt, lt_tree x Leaf. -Proof. - red; inversion 1. -Qed. - -Lemma gt_leaf : forall x : elt, gt_tree x Leaf. -Proof. - red; inversion 1. -Qed. - -Lemma lt_tree_node : - forall (x y : elt) (l r : tree) (h : int), - lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h). -Proof. - unfold lt_tree; intuition_in; order. -Qed. - -Lemma gt_tree_node : - forall (x y : elt) (l r : tree) (h : int), - gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h). -Proof. - unfold gt_tree; intuition_in; order. -Qed. - -Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. - -Lemma lt_tree_not_in : - forall (x : elt) (t : tree), lt_tree x t -> ~ In x t. -Proof. - intros; intro; order. -Qed. - -Lemma lt_tree_trans : - forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t. -Proof. - eauto. -Qed. - -Lemma gt_tree_not_in : - forall (x : elt) (t : tree), gt_tree x t -> ~ In x t. -Proof. - intros; intro; order. -Qed. - -Lemma gt_tree_trans : - forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t. -Proof. - eauto. -Qed. - -Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. - -(** * Inductions principles *) - -Functional Scheme mem_ind := Induction for mem Sort Prop. -Functional Scheme bal_ind := Induction for bal Sort Prop. -Functional Scheme add_ind := Induction for add Sort Prop. -Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. -Functional Scheme merge_ind := Induction for merge Sort Prop. -Functional Scheme remove_ind := Induction for remove Sort Prop. -Functional Scheme min_elt_ind := Induction for min_elt Sort Prop. -Functional Scheme max_elt_ind := Induction for max_elt Sort Prop. -Functional Scheme concat_ind := Induction for concat Sort Prop. -Functional Scheme split_ind := Induction for split Sort Prop. -Functional Scheme inter_ind := Induction for inter Sort Prop. -Functional Scheme diff_ind := Induction for diff Sort Prop. -Functional Scheme union_ind := Induction for union Sort Prop. - - -(** * Empty set *) - -Lemma empty_1 : Empty empty. -Proof. - intro; intro. - inversion H. -Qed. - -Lemma empty_bst : bst empty. -Proof. - auto. -Qed. - -(** * Emptyness test *) - -Lemma is_empty_1 : forall s, Empty s -> is_empty s = true. -Proof. - destruct s as [|r x l h]; simpl; auto. - intro H; elim (H x); auto. -Qed. - -Lemma is_empty_2 : forall s, is_empty s = true -> Empty s. -Proof. - destruct s; simpl; intros; try discriminate; red; auto. -Qed. - - - -(** * Appartness *) - -Lemma mem_1 : forall s x, bst s -> In x s -> mem x s = true. -Proof. - intros s x; functional induction mem x s; auto; intros; try clear e0; - inv bst; intuition_in; order. -Qed. - -Lemma mem_2 : forall s x, mem x s = true -> In x s. -Proof. - intros s x; functional induction mem x s; auto; intros; discriminate. -Qed. - - - -(** * Singleton set *) - -Lemma singleton_1 : forall x y, In y (singleton x) -> X.eq x y. -Proof. - unfold singleton; intros; inv In; order. -Qed. - -Lemma singleton_2 : forall x y, X.eq x y -> In y (singleton x). -Proof. - unfold singleton; auto. -Qed. - -Lemma singleton_bst : forall x : elt, bst (singleton x). -Proof. - unfold singleton; auto. -Qed. - - - -(** * Helper functions *) - -Lemma create_in : - forall l x r y, In y (create l x r) <-> X.eq y x \/ In y l \/ In y r. -Proof. - unfold create; split; [ inversion_clear 1 | ]; intuition. -Qed. - -Lemma create_bst : - forall l x r, bst l -> bst r -> lt_tree x l -> gt_tree x r -> - bst (create l x r). -Proof. - unfold create; auto. -Qed. -Hint Resolve create_bst. - -Lemma bal_in : forall l x r y, - In y (bal l x r) <-> X.eq y x \/ In y l \/ In y r. -Proof. - intros l x r; functional induction bal l x r; intros; try clear e0; - rewrite !create_in; intuition_in. -Qed. - -Lemma bal_bst : forall l x r, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (bal l x r). -Proof. - intros l x r; functional induction bal l x r; intros; - inv bst; repeat apply create_bst; auto; unfold create; - (apply lt_tree_node || apply gt_tree_node); auto; - (eapply lt_tree_trans || eapply gt_tree_trans); eauto. -Qed. -Hint Resolve bal_bst. - - - -(** * Insertion *) - -Lemma add_in : forall s x y, - In y (add x s) <-> X.eq y x \/ In y s. -Proof. - intros s x; functional induction (add x s); auto; intros; - try rewrite bal_in, IHt; intuition_in. - eapply In_1; eauto. -Qed. - -Lemma add_bst : forall s x, bst s -> bst (add x s). -Proof. - intros s x; functional induction (add x s); auto; intros; - inv bst; apply bal_bst; auto. - (* lt_tree -> lt_tree (add ...) *) - red; red in H3. - intros. - rewrite add_in in H. - intuition. - eauto. - inv bst; auto using bal_bst. - (* gt_tree -> gt_tree (add ...) *) - red; red in H3. - intros. - rewrite add_in in H. - intuition. - apply MX.lt_eq with x; auto. -Qed. -Hint Resolve add_bst. - - +(** This is just a compatibility layer, the real implementation + is now in [MSetAVL] *) -(** * Join *) - -(* Function/Functional Scheme can't deal with internal fix. - Let's do its job by hand: *) - -Ltac join_tac := - intro l; induction l as [| ll _ lx lr Hlr lh]; - [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join; - [ | destruct (gt_le_dec lh (rh+2)); - [ match goal with |- context b [ bal ?a ?b ?c] => - replace (bal a b c) - with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto] - end - | destruct (gt_le_dec rh (lh+2)); - [ match goal with |- context b [ bal ?a ?b ?c] => - replace (bal a b c) - with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto] - end - | ] ] ] ]; intros. - -Lemma join_in : forall l x r y, - In y (join l x r) <-> X.eq y x \/ In y l \/ In y r. -Proof. - join_tac. - simpl. - rewrite add_in; intuition_in. - rewrite add_in; intuition_in. - rewrite bal_in, Hlr; clear Hlr Hrl; intuition_in. - rewrite bal_in, Hrl; clear Hlr Hrl; intuition_in. - apply create_in. -Qed. - -Lemma join_bst : forall l x r, bst l -> bst r -> - lt_tree x l -> gt_tree x r -> bst (join l x r). -Proof. - join_tac; auto; inv bst; apply bal_bst; auto; - clear Hrl Hlr z; intro; intros; rewrite join_in in *. - intuition; [ apply MX.lt_eq with x | ]; eauto. - intuition; [ apply MX.eq_lt with x | ]; eauto. -Qed. -Hint Resolve join_bst. - - - -(** * Extraction of minimum element *) - -Lemma remove_min_in : forall l x r h y, - In y (Node l x r h) <-> - X.eq y (remove_min l x r)#2 \/ In y (remove_min l x r)#1. -Proof. - intros l x r; functional induction (remove_min l x r); simpl in *; intros. - intuition_in. - rewrite bal_in, In_node_iff, IHp, e0; simpl; intuition. -Qed. - -Lemma remove_min_bst : forall l x r h, - bst (Node l x r h) -> bst (remove_min l x r)#1. -Proof. - intros l x r; functional induction (remove_min l x r); simpl; intros. - inv bst; auto. - inversion_clear H. - specialize IHp with (1:=H0); rewrite e0 in IHp; auto. - apply bal_bst; auto. - intro y; specialize (H2 y). - rewrite remove_min_in, e0 in H2; simpl in H2; intuition. -Qed. - -Lemma remove_min_gt_tree : forall l x r h, - bst (Node l x r h) -> - gt_tree (remove_min l x r)#2 (remove_min l x r)#1. -Proof. - intros l x r; functional induction (remove_min l x r); simpl; intros. - inv bst; auto. - inversion_clear H. - specialize IHp with (1:=H0); rewrite e0 in IHp; simpl in IHp. - intro y; rewrite bal_in; intuition; - specialize (H2 m); rewrite remove_min_in, e0 in H2; simpl in H2; - [ apply MX.lt_eq with x | ]; eauto. -Qed. -Hint Resolve remove_min_bst remove_min_gt_tree. - - - -(** * Merging two trees *) - -Lemma merge_in : forall s1 s2 y, - In y (merge s1 s2) <-> In y s1 \/ In y s2. -Proof. - intros s1 s2; functional induction (merge s1 s2); intros; - try factornode _x _x0 _x1 _x2 as s1. - intuition_in. - intuition_in. - rewrite bal_in, remove_min_in, e1; simpl; intuition. -Qed. - -Lemma merge_bst : forall s1 s2, bst s1 -> bst s2 -> - (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> - bst (merge s1 s2). -Proof. - intros s1 s2; functional induction (merge s1 s2); intros; auto; - try factornode _x _x0 _x1 _x2 as s1. - apply bal_bst; auto. - change s2' with ((s2',m)#1); rewrite <-e1; eauto. - intros y Hy. - apply H1; auto. - rewrite remove_min_in, e1; simpl; auto. - change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto. -Qed. -Hint Resolve merge_bst. - - - -(** * Deletion *) - -Lemma remove_in : forall s x y, bst s -> - (In y (remove x s) <-> ~ X.eq y x /\ In y s). -Proof. - intros s x; functional induction (remove x s); intros; inv bst. - intuition_in. - rewrite bal_in, IHt; clear e0 IHt; intuition; [order|order|intuition_in]. - rewrite merge_in; clear e0; intuition; [order|order|intuition_in]. - elim H4; eauto. - rewrite bal_in, IHt; clear e0 IHt; intuition; [order|order|intuition_in]. -Qed. - -Lemma remove_bst : forall s x, bst s -> bst (remove x s). -Proof. - intros s x; functional induction (remove x s); intros; inv bst. - auto. - (* LT *) - apply bal_bst; auto. - intro z; rewrite remove_in; auto; destruct 1; eauto. - (* EQ *) - eauto. - (* GT *) - apply bal_bst; auto. - intro z; rewrite remove_in; auto; destruct 1; eauto. -Qed. -Hint Resolve remove_bst. - - -(** * Minimum element *) - -Lemma min_elt_1 : forall s x, min_elt s = Some x -> In x s. -Proof. - intro s; functional induction (min_elt s); auto; inversion 1; auto. -Qed. - -Lemma min_elt_2 : forall s x y, bst s -> - min_elt s = Some x -> In y s -> ~ X.lt y x. -Proof. - intro s; functional induction (min_elt s); - try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. - inversion_clear 2. - inversion_clear 1. - inversion 1; subst. - inversion_clear 1; auto. - inversion_clear H5. - inversion_clear 1. - simpl. - destruct l1. - inversion 1; subst. - assert (X.lt x y) by (apply H2; auto). - inversion_clear 1; auto; order. - assert (X.lt x1 y) by auto. - inversion_clear 2; auto; - (assert (~ X.lt x1 x) by auto); order. -Qed. - -Lemma min_elt_3 : forall s, min_elt s = None -> Empty s. -Proof. - intro s; functional induction (min_elt s). - red; red; inversion 2. - inversion 1. - intro H0. - destruct (IHo H0 _x2); auto. -Qed. - - - -(** * Maximum element *) - -Lemma max_elt_1 : forall s x, max_elt s = Some x -> In x s. -Proof. - intro s; functional induction (max_elt s); auto; inversion 1; auto. -Qed. - -Lemma max_elt_2 : forall s x y, bst s -> - max_elt s = Some x -> In y s -> ~ X.lt x y. -Proof. - intro s; functional induction (max_elt s); - try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. - inversion_clear 2. - inversion_clear 1. - inversion 1; subst. - inversion_clear 1; auto. - inversion_clear H5. - inversion_clear 1. - assert (X.lt y x1) by auto. - inversion_clear 2; auto; - (assert (~ X.lt x x1) by auto); order. -Qed. - -Lemma max_elt_3 : forall s, max_elt s = None -> Empty s. -Proof. - intro s; functional induction (max_elt s). - red; auto. - inversion 1. - intros H0; destruct (IHo H0 _x2); auto. -Qed. - - - -(** * Any element *) - -Lemma choose_1 : forall s x, choose s = Some x -> In x s. -Proof. - exact min_elt_1. -Qed. - -Lemma choose_2 : forall s, choose s = None -> Empty s. -Proof. - exact min_elt_3. -Qed. - -Lemma choose_3 : forall s s', bst s -> bst s' -> - forall x x', choose s = Some x -> choose s' = Some x' -> - Equal s s' -> X.eq x x'. -Proof. - unfold choose, Equal; intros s s' Hb Hb' x x' Hx Hx' H. - assert (~X.lt x x'). - apply min_elt_2 with s'; auto. - rewrite <-H; auto using min_elt_1. - assert (~X.lt x' x). - apply min_elt_2 with s; auto. - rewrite H; auto using min_elt_1. - destruct (X.compare x x'); intuition. -Qed. - - -(** * Concatenation *) - -Lemma concat_in : forall s1 s2 y, - In y (concat s1 s2) <-> In y s1 \/ In y s2. -Proof. - intros s1 s2; functional induction (concat s1 s2); intros; - try factornode _x _x0 _x1 _x2 as s1. - intuition_in. - intuition_in. - rewrite join_in, remove_min_in, e1; simpl; intuition. -Qed. - -Lemma concat_bst : forall s1 s2, bst s1 -> bst s2 -> - (forall y1 y2 : elt, In y1 s1 -> In y2 s2 -> X.lt y1 y2) -> - bst (concat s1 s2). -Proof. - intros s1 s2; functional induction (concat s1 s2); intros; auto; - try factornode _x _x0 _x1 _x2 as s1. - apply join_bst; auto. - change (bst (s2',m)#1); rewrite <-e1; eauto. - intros y Hy. - apply H1; auto. - rewrite remove_min_in, e1; simpl; auto. - change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto. -Qed. -Hint Resolve concat_bst. - - -(** * Splitting *) - -Lemma split_in_1 : forall s x y, bst s -> - (In y (split x s)#l <-> In y s /\ X.lt y x). -Proof. - intros s x; functional induction (split x s); simpl; intros; - inv bst; try clear e0. - intuition_in. - rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. - intuition_in; order. - rewrite join_in. - rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. -Qed. - -Lemma split_in_2 : forall s x y, bst s -> - (In y (split x s)#r <-> In y s /\ X.lt x y). -Proof. - intros s x; functional induction (split x s); subst; simpl; intros; - inv bst; try clear e0. - intuition_in. - rewrite join_in. - rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. - intuition_in; order. - rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. -Qed. - -Lemma split_in_3 : forall s x, bst s -> - ((split x s)#b = true <-> In x s). -Proof. - intros s x; functional induction (split x s); subst; simpl; intros; - inv bst; try clear e0. - intuition_in; try discriminate. - rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. - intuition. - rewrite e1 in IHt; simpl in IHt; rewrite IHt; intuition_in; order. -Qed. - -Lemma split_bst : forall s x, bst s -> - bst (split x s)#l /\ bst (split x s)#r. -Proof. - intros s x; functional induction (split x s); subst; simpl; intros; - inv bst; try clear e0; try rewrite e1 in *; simpl in *; intuition; - apply join_bst; auto. - intros y0. - generalize (split_in_2 x y0 H0); rewrite e1; simpl; intuition. - intros y0. - generalize (split_in_1 x y0 H1); rewrite e1; simpl; intuition. -Qed. - - - -(** * Intersection *) - -Lemma inter_bst_in : forall s1 s2, bst s1 -> bst s2 -> - bst (inter s1 s2) /\ (forall y, In y (inter s1 s2) <-> In y s1 /\ In y s2). -Proof. - intros s1 s2; functional induction inter s1 s2; intros B1 B2; - [intuition_in|intuition_in | | ]; - factornode _x0 _x1 _x2 _x3 as s2; - generalize (split_bst x1 B2); - rewrite e1; simpl; destruct 1; inv bst; - destruct IHt as (IHb1,IHi1); auto; - destruct IHt0 as (IHb2,IHi2); auto; - generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1) - (split_in_3 x1 B2)(split_bst x1 B2); - rewrite e1; simpl; split; intros. - (* bst join *) - apply join_bst; auto; intro y; [rewrite IHi1|rewrite IHi2]; intuition. (* In join *) - rewrite join_in, IHi1, IHi2, H5, H6; intuition_in. - apply In_1 with x1; auto. - (* bst concat *) - apply concat_bst; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order. - (* In concat *) - rewrite concat_in, IHi1, IHi2, H5, H6; auto. - assert (~In x1 s2) by (rewrite <- H7; auto). - intuition_in. - elim H9. - apply In_1 with y; auto. -Qed. - -Lemma inter_in : forall s1 s2 y, bst s1 -> bst s2 -> - (In y (inter s1 s2) <-> In y s1 /\ In y s2). -Proof. - intros s1 s2 y B1 B2; destruct (inter_bst_in B1 B2); auto. -Qed. - -Lemma inter_bst : forall s1 s2, bst s1 -> bst s2 -> bst (inter s1 s2). -Proof. - intros s1 s2 B1 B2; destruct (inter_bst_in B1 B2); auto. -Qed. - - -(** * Difference *) - -Lemma diff_bst_in : forall s1 s2, bst s1 -> bst s2 -> - bst (diff s1 s2) /\ (forall y, In y (diff s1 s2) <-> In y s1 /\ ~In y s2). -Proof. - intros s1 s2; functional induction diff s1 s2; intros B1 B2; - [intuition_in|intuition_in | | ]; - factornode _x0 _x1 _x2 _x3 as s2; - generalize (split_bst x1 B2); - rewrite e1; simpl; destruct 1; - inv avl; inv bst; - destruct IHt as (IHb1,IHi1); auto; - destruct IHt0 as (IHb2,IHi2); auto; - generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1) - (split_in_3 x1 B2)(split_bst x1 B2); - rewrite e1; simpl; split; intros. - (* bst concat *) - apply concat_bst; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order. - (* In concat *) - rewrite concat_in, IHi1, IHi2, H5, H6; intuition_in. - elim H13. - apply In_1 with x1; auto. - (* bst join *) - apply join_bst; auto; intro y; [rewrite IHi1|rewrite IHi2]; intuition. (* In join *) - rewrite join_in, IHi1, IHi2, H5, H6; auto. - assert (~In x1 s2) by (rewrite <- H7; auto). - intuition_in. - elim H9. - apply In_1 with y; auto. -Qed. - -Lemma diff_in : forall s1 s2 y, bst s1 -> bst s2 -> - (In y (diff s1 s2) <-> In y s1 /\ ~In y s2). -Proof. - intros s1 s2 y B1 B2; destruct (diff_bst_in B1 B2); auto. -Qed. - -Lemma diff_bst : forall s1 s2, bst s1 -> bst s2 -> bst (diff s1 s2). -Proof. - intros s1 s2 B1 B2; destruct (diff_bst_in B1 B2); auto. -Qed. - - -(** * Union *) - -Lemma union_in : forall s1 s2 y, bst s1 -> bst s2 -> - (In y (union s1 s2) <-> In y s1 \/ In y s2). -Proof. - intros s1 s2; functional induction union s1 s2; intros y B1 B2. - intuition_in. - intuition_in. - factornode _x0 _x1 _x2 _x3 as s2. - generalize (split_in_1 x1 y B2)(split_in_2 x1 y B2)(split_bst x1 B2). - rewrite e1; simpl. - destruct 3; inv bst. - rewrite join_in, IHt, IHt0, H, H0; auto. - case (X.compare y x1); intuition_in. -Qed. - -Lemma union_bst : forall s1 s2, bst s1 -> bst s2 -> - bst (union s1 s2). -Proof. - intros s1 s2; functional induction union s1 s2; intros B1 B2; auto. - factornode _x0 _x1 _x2 _x3 as s2. - generalize (@split_in_1 s2 x1)(@split_in_2 s2 x1)(split_bst x1 B2). - rewrite e1; simpl; destruct 3. - inv bst. - apply join_bst; auto. - intro y; rewrite union_in, H; intuition_in. - intro y; rewrite union_in, H0; intuition_in. -Qed. - - -(** * Elements *) - -Lemma elements_aux_in : forall s acc x, - InA X.eq x (elements_aux acc s) <-> In x s \/ InA X.eq x acc. -Proof. - induction s as [ | l Hl x r Hr h ]; simpl; auto. - intuition. - inversion H0. - intros. - rewrite Hl. - destruct (Hr acc x0); clear Hl Hr. - intuition; inversion_clear H3; intuition. -Qed. - -Lemma elements_in : forall s x, InA X.eq x (elements s) <-> In x s. -Proof. - intros; generalize (elements_aux_in s nil x); intuition. - inversion_clear H0. -Qed. - -Lemma elements_aux_sort : forall s acc, bst s -> sort X.lt acc -> - (forall x y : elt, InA X.eq x acc -> In y s -> X.lt y x) -> - sort X.lt (elements_aux acc s). -Proof. - induction s as [ | l Hl y r Hr h]; simpl; intuition. - inv bst. - apply Hl; auto. - constructor. - apply Hr; auto. - apply MX.In_Inf; intros. - destruct (elements_aux_in r acc y0); intuition. - intros. - inversion_clear H. - order. - destruct (elements_aux_in r acc x); intuition eauto. -Qed. - -Lemma elements_sort : forall s : tree, bst s -> sort X.lt (elements s). -Proof. - intros; unfold elements; apply elements_aux_sort; auto. - intros; inversion H0. -Qed. -Hint Resolve elements_sort. - -Lemma elements_nodup : forall s : tree, bst s -> NoDupA X.eq (elements s). -Proof. - auto. -Qed. - -Lemma elements_aux_cardinal : - forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s). -Proof. - simple induction s; simpl in |- *; intuition. - rewrite <- H. - simpl in |- *. - rewrite <- H0; omega. -Qed. - -Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s). -Proof. - exact (fun s => elements_aux_cardinal s nil). -Qed. - -Lemma elements_app : - forall s acc, elements_aux acc s = elements s ++ acc. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1, IHs2. - unfold elements; simpl. - rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto. -Qed. - -Lemma elements_node : - forall l x r h acc, - elements l ++ x :: elements r ++ acc = - elements (Node l x r h) ++ acc. -Proof. - unfold elements; simpl; intros; auto. - rewrite !elements_app, <- !app_nil_end, !app_ass; auto. -Qed. - - -(** * Filter *) - -Section F. -Variable f : elt -> bool. - -Lemma filter_acc_in : forall s acc, - compat_bool X.eq f -> forall x : elt, - In x (filter_acc f acc s) <-> In x acc \/ In x s /\ f x = true. -Proof. - induction s; simpl; intros. - intuition_in. - rewrite IHs2, IHs1 by (destruct (f t); auto). - case_eq (f t); intros. - rewrite (add_in); auto. - intuition_in. - rewrite (H _ _ H2). - intuition. - intuition_in. - rewrite (H _ _ H2) in H3. - rewrite H0 in H3; discriminate. -Qed. - -Lemma filter_acc_bst : forall s acc, bst s -> bst acc -> - bst (filter_acc f acc s). -Proof. - induction s; simpl; auto. - intros. - inv bst. - destruct (f t); auto. -Qed. - -Lemma filter_in : forall s, - compat_bool X.eq f -> forall x : elt, - In x (filter f s) <-> In x s /\ f x = true. -Proof. - unfold filter; intros; rewrite filter_acc_in; intuition_in. -Qed. - -Lemma filter_bst : forall s, bst s -> bst (filter f s). -Proof. - unfold filter; intros; apply filter_acc_bst; auto. -Qed. - - - -(** * Partition *) - -Lemma partition_acc_in_1 : forall s acc, - compat_bool X.eq f -> forall x : elt, - In x (partition_acc f acc s)#1 <-> - In x acc#1 \/ In x s /\ f x = true. -Proof. - induction s; simpl; intros. - intuition_in. - destruct acc as [acct accf]; simpl in *. - rewrite IHs2 by - (destruct (f t); auto; apply partition_acc_avl_1; simpl; auto). - rewrite IHs1 by (destruct (f t); simpl; auto). - case_eq (f t); simpl; intros. - rewrite (add_in); auto. - intuition_in. - rewrite (H _ _ H2). - intuition. - intuition_in. - rewrite (H _ _ H2) in H3. - rewrite H0 in H3; discriminate. -Qed. - -Lemma partition_acc_in_2 : forall s acc, - compat_bool X.eq f -> forall x : elt, - In x (partition_acc f acc s)#2 <-> - In x acc#2 \/ In x s /\ f x = false. -Proof. - induction s; simpl; intros. - intuition_in. - destruct acc as [acct accf]; simpl in *. - rewrite IHs2 by - (destruct (f t); auto; apply partition_acc_avl_2; simpl; auto). - rewrite IHs1 by (destruct (f t); simpl; auto). - case_eq (f t); simpl; intros. - intuition. - intuition_in. - rewrite (H _ _ H2) in H3. - rewrite H0 in H3; discriminate. - rewrite (add_in); auto. - intuition_in. - rewrite (H _ _ H2). - intuition. -Qed. - -Lemma partition_in_1 : forall s, - compat_bool X.eq f -> forall x : elt, - In x (partition f s)#1 <-> In x s /\ f x = true. -Proof. - unfold partition; intros; rewrite partition_acc_in_1; - simpl in *; intuition_in. -Qed. - -Lemma partition_in_2 : forall s, - compat_bool X.eq f -> forall x : elt, - In x (partition f s)#2 <-> In x s /\ f x = false. -Proof. - unfold partition; intros; rewrite partition_acc_in_2; - simpl in *; intuition_in. -Qed. - -Lemma partition_acc_bst_1 : forall s acc, bst s -> bst acc#1 -> - bst (partition_acc f acc s)#1. -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. - inv bst. - destruct (f t); auto. - apply IHs2; simpl; auto. - apply IHs1; simpl; auto. -Qed. - -Lemma partition_acc_bst_2 : forall s acc, bst s -> bst acc#2 -> - bst (partition_acc f acc s)#2. -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. - inv bst. - destruct (f t); auto. - apply IHs2; simpl; auto. - apply IHs1; simpl; auto. -Qed. - -Lemma partition_bst_1 : forall s, bst s -> bst (partition f s)#1. -Proof. - unfold partition; intros; apply partition_acc_bst_1; auto. -Qed. - -Lemma partition_bst_2 : forall s, bst s -> bst (partition f s)#2. -Proof. - unfold partition; intros; apply partition_acc_bst_2; auto. -Qed. - - - -(** * [for_all] and [exists] *) - -Lemma for_all_1 : forall s, compat_bool X.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. -Proof. - induction s; simpl; auto. - intros. - rewrite IHs1; try red; auto. - rewrite IHs2; try red; auto. - generalize (H0 t). - destruct (f t); simpl; auto. -Qed. - -Lemma for_all_2 : forall s, compat_bool X.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. -Proof. - induction s; simpl; auto; intros; red; intros; inv In. - destruct (andb_prop _ _ H0); auto. - destruct (andb_prop _ _ H1); eauto. - apply IHs1; auto. - destruct (andb_prop _ _ H0); auto. - destruct (andb_prop _ _ H1); auto. - apply IHs2; auto. - destruct (andb_prop _ _ H0); auto. -Qed. - -Lemma exists_1 : forall s, compat_bool X.eq f -> - Exists (fun x => f x = true) s -> exists_ f s = true. -Proof. - induction s; simpl; destruct 2 as (x,(U,V)); inv In; rewrite <- ?orb_lazy_alt. - rewrite (H _ _ (X.eq_sym H0)); rewrite V; auto. - apply orb_true_intro; left. - apply orb_true_intro; right; apply IHs1; auto; exists x; auto. - apply orb_true_intro; right; apply IHs2; auto; exists x; auto. -Qed. - -Lemma exists_2 : forall s, compat_bool X.eq f -> - exists_ f s = true -> Exists (fun x => f x = true) s. -Proof. - induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *. - discriminate. - destruct (orb_true_elim _ _ H0) as [H1|H1]. - destruct (orb_true_elim _ _ H1) as [H2|H2]. - exists t; auto. - destruct (IHs1 H H2); auto; exists x; intuition. - destruct (IHs2 H H1); auto; exists x; intuition. -Qed. - -End F. - - - -(** * Fold *) - -Definition fold' (A : Type) (f : elt -> A -> A)(s : tree) := - L.fold f (elements s). -Implicit Arguments fold' [A]. - -Lemma fold_equiv_aux : - forall (A : Type) (s : tree) (f : elt -> A -> A) (a : A) (acc : list elt), - L.fold f (elements_aux acc s) a = L.fold f acc (fold f s a). -Proof. - simple induction s. - simpl in |- *; intuition. - simpl in |- *; intros. - rewrite H. - simpl. - apply H0. -Qed. - -Lemma fold_equiv : - forall (A : Type) (s : tree) (f : elt -> A -> A) (a : A), - fold f s a = fold' f s a. -Proof. - unfold fold', elements in |- *. - simple induction s; simpl in |- *; auto; intros. - rewrite fold_equiv_aux. - rewrite H0. - simpl in |- *; auto. -Qed. - -Lemma fold_1 : - forall (s:t)(Hs:bst s)(A : Type)(f : elt -> A -> A)(i : A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. -Proof. - intros. - rewrite fold_equiv. - unfold fold'. - rewrite L.fold_1. - unfold L.elements; auto. - apply elements_sort; auto. -Qed. - -(** * Subset *) - -Lemma subsetl_12 : forall subset_l1 l1 x1 h1 s2, - bst (Node l1 x1 Leaf h1) -> bst s2 -> - (forall s, bst s -> (subset_l1 s = true <-> Subset l1 s)) -> - (subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ). -Proof. - induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. - unfold Subset; intuition; try discriminate. - assert (H': In x1 Leaf) by auto; inversion H'. - inversion_clear H0. - specialize (IHl2 H H2 H1). - specialize (IHr2 H H3 H1). - inv bst. clear H8. - destruct X.compare. - - rewrite IHl2; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (X.eq a x2) by order; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (H':=mem_2 H6); apply In_1 with x1; auto. - apply mem_1; auto. - assert (In x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order. -Qed. - - -Lemma subsetr_12 : forall subset_r1 r1 x1 h1 s2, - bst (Node Leaf x1 r1 h1) -> bst s2 -> - (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> - (subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2). -Proof. - induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. - unfold Subset; intuition; try discriminate. - assert (H': In x1 Leaf) by auto; inversion H'. - inversion_clear H0. - specialize (IHl2 H H2 H1). - specialize (IHr2 H H3 H1). - inv bst. clear H7. - destruct X.compare. - - rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (H':=mem_2 H1); apply In_1 with x1; auto. - apply mem_1; auto. - assert (In x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite H1 by auto; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (X.eq a x2) by order; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite IHr2; clear H1 IHl2 IHr2. - unfold Subset. intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. -Qed. - - -Lemma subset_12 : forall s1 s2, bst s1 -> bst s2 -> - (subset s1 s2 = true <-> Subset s1 s2). -Proof. - induction s1 as [|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros. - unfold Subset; intuition_in. - destruct s2 as [|l2 x2 r2 h2]; simpl; intros. - unfold Subset; intuition_in; try discriminate. - assert (H': In x1 Leaf) by auto; inversion H'. - inv bst. - destruct X.compare. - - rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto. - rewrite (@subsetl_12 (subset l1) l1 x1 h1) by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - assert (X.eq a x2) by order; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - - rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto. - rewrite (@subsetr_12 (subset r1) r1 x1 h1) by auto. - clear IHl1 IHr1. - unfold Subset; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. -Qed. - - - -(** * Comparison *) - -(** ** Relations [eq] and [lt] over trees *) - -Definition eq := Equal. -Definition lt (s1 s2 : t) : Prop := L.lt (elements s1) (elements s2). - -Lemma eq_refl : forall s : t, Equal s s. -Proof. - unfold Equal; intuition. -Qed. - -Lemma eq_sym : forall s s' : t, Equal s s' -> Equal s' s. -Proof. - unfold Equal; intros s s' H x; destruct (H x); split; auto. -Qed. - -Lemma eq_trans : forall s s' s'' : t, - Equal s s' -> Equal s' s'' -> Equal s s''. -Proof. - unfold Equal; intros s s' s'' H1 H2 x; - destruct (H1 x); destruct (H2 x); split; auto. -Qed. - -Lemma eq_L_eq : - forall s s' : t, Equal s s' -> L.eq (elements s) (elements s'). -Proof. - unfold Equal, L.eq, L.Equal; intros; do 2 rewrite elements_in; auto. -Qed. - -Lemma L_eq_eq : - forall s s' : t, L.eq (elements s) (elements s') -> Equal s s'. -Proof. - unfold Equal, L.eq, L.Equal; intros; do 2 rewrite <-elements_in; auto. -Qed. -Hint Resolve eq_L_eq L_eq_eq. - -Definition lt_trans (s s' s'' : t) (h : lt s s') - (h' : lt s' s'') : lt s s'' := L.lt_trans h h'. - -Lemma lt_not_eq : forall s s' : t, - bst s -> bst s' -> lt s s' -> ~ Equal s s'. -Proof. - unfold lt in |- *; intros; intro. - apply L.lt_not_eq with (s := elements s) (s' := elements s'); auto. -Qed. - -Lemma L_eq_cons : - forall (l1 l2 : list elt) (x y : elt), - X.eq x y -> L.eq l1 l2 -> L.eq (x :: l1) (y :: l2). -Proof. - unfold L.eq, L.Equal in |- *; intuition. - inversion_clear H1; generalize (H0 a); clear H0; intuition. - apply InA_eqA with x; eauto. - inversion_clear H1; generalize (H0 a); clear H0; intuition. - apply InA_eqA with y; eauto. -Qed. -Hint Resolve L_eq_cons. - - -(** * A new comparison algorithm suggested by Xavier Leroy *) - -(** [flatten_e e] returns the list of elements of [e] i.e. the list - of elements actually compared *) - -Fixpoint flatten_e (e : enumeration) : list elt := match e with - | End => nil - | More x t r => x :: elements t ++ flatten_e r - end. - -Lemma flatten_e_elements : - forall l x r h e, - elements l ++ flatten_e (More x r e) = elements (Node l x r h) ++ flatten_e e. -Proof. - intros; simpl; apply elements_node. -Qed. - -Lemma cons_1 : forall s e, - flatten_e (cons s e) = elements s ++ flatten_e e. -Proof. - induction s; simpl; auto; intros. - rewrite IHs1; apply flatten_e_elements. -Qed. - -(** Correctness of this comparison *) - -Definition Cmp c := - match c with - | Eq => L.eq - | Lt => L.lt - | Gt => (fun l1 l2 => L.lt l2 l1) - end. - -Lemma cons_Cmp : forall c x1 x2 l1 l2, X.eq x1 x2 -> - Cmp c l1 l2 -> Cmp c (x1::l1) (x2::l2). -Proof. - destruct c; simpl; auto. -Qed. -Hint Resolve cons_Cmp. - -Lemma compare_end_Cmp : - forall e2, Cmp (compare_end e2) nil (flatten_e e2). -Proof. - destruct e2; simpl; auto. - apply L.eq_refl. -Qed. - -Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, - Cmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> - Cmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) - (flatten_e (More x2 r2 e2)). -Proof. - simpl; intros; destruct X.compare; simpl; auto. -Qed. - -Lemma compare_cont_Cmp : forall s1 cont e2 l, - (forall e, Cmp (cont e) l (flatten_e e)) -> - Cmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2). -Proof. - induction s1 as [|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto. - rewrite <- elements_node; simpl. - apply Hl1; auto. clear e2. intros [|x2 r2 e2]. - simpl; auto. - apply compare_more_Cmp. - rewrite <- cons_1; auto. -Qed. - -Lemma compare_Cmp : forall s1 s2, - Cmp (compare s1 s2) (elements s1) (elements s2). -Proof. - intros; unfold compare. - rewrite (app_nil_end (elements s1)). - replace (elements s2) with (flatten_e (cons s2 End)) by - (rewrite cons_1; simpl; rewrite <- app_nil_end; auto). - apply compare_cont_Cmp; auto. - intros. - apply compare_end_Cmp; auto. -Qed. - -(** * Equality test *) - -Lemma equal_1 : forall s1 s2, bst s1 -> bst s2 -> - Equal s1 s2 -> equal s1 s2 = true. -Proof. -unfold equal; intros s1 s2 B1 B2 E. -generalize (compare_Cmp s1 s2). -destruct (compare s1 s2); simpl in *; auto; intros. -elim (lt_not_eq B1 B2 H E); auto. -elim (lt_not_eq B2 B1 H (eq_sym E)); auto. -Qed. - -Lemma equal_2 : forall s1 s2, - equal s1 s2 = true -> Equal s1 s2. -Proof. -unfold equal; intros s1 s2 E. -generalize (compare_Cmp s1 s2); - destruct compare; auto; discriminate. -Qed. - -End Proofs. - -End Raw. - - - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of binary search trees. - They also happen to be well-balanced, but this has no influence - on the correctness of operations, so we won't state this here, - see [FSetFullAVL] if you need more than just the FSet interface. -*) +Require FSetCompat MSetAVL Orders OrdersAlt. Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. - - Module E := X. - Module Raw := Raw I X. - Import Raw.Proofs. - - Record bst := Bst {this :> Raw.t; is_bst : Raw.bst this}. - Definition t := bst. - Definition elt := E.t. - - Definition In (x : elt) (s : t) := Raw.In x s. - Definition Equal (s s':t) := forall a : elt, In a s <-> In a s'. - Definition Subset (s s':t) := forall a : elt, In a s -> In a s'. - Definition Empty (s:t) := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) (s:t) := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) (s:t) := exists x, In x s /\ P x. - - Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. - Proof. intro s; exact (@In_1 s). Qed. - - Definition mem (x:elt)(s:t) : bool := Raw.mem x s. - - Definition empty : t := Bst empty_bst. - Definition is_empty (s:t) : bool := Raw.is_empty s. - Definition singleton (x:elt) : t := Bst (singleton_bst x). - Definition add (x:elt)(s:t) : t := Bst (add_bst x (is_bst s)). - Definition remove (x:elt)(s:t) : t := Bst (remove_bst x (is_bst s)). - Definition inter (s s':t) : t := Bst (inter_bst (is_bst s) (is_bst s')). - Definition union (s s':t) : t := Bst (union_bst (is_bst s) (is_bst s')). - Definition diff (s s':t) : t := Bst (diff_bst (is_bst s) (is_bst s')). - Definition elements (s:t) : list elt := Raw.elements s. - Definition min_elt (s:t) : option elt := Raw.min_elt s. - Definition max_elt (s:t) : option elt := Raw.max_elt s. - Definition choose (s:t) : option elt := Raw.choose s. - Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := Raw.fold f s. - Definition cardinal (s:t) : nat := Raw.cardinal s. - Definition filter (f : elt -> bool) (s:t) : t := - Bst (filter_bst f (is_bst s)). - Definition for_all (f : elt -> bool) (s:t) : bool := Raw.for_all f s. - Definition exists_ (f : elt -> bool) (s:t) : bool := Raw.exists_ f s. - Definition partition (f : elt -> bool) (s:t) : t * t := - let p := Raw.partition f s in - (@Bst (fst p) (partition_bst_1 f (is_bst s)), - @Bst (snd p) (partition_bst_2 f (is_bst s))). - - Definition equal (s s':t) : bool := Raw.equal s s'. - Definition subset (s s':t) : bool := Raw.subset s s'. - - Definition eq (s s':t) : Prop := Raw.Equal s s'. - Definition lt (s s':t) : Prop := Raw.Proofs.lt s s'. - - Definition compare (s s':t) : Compare lt eq s s'. - Proof. - intros (s,b) (s',b'). - generalize (compare_Cmp s s'). - destruct Raw.compare; intros; [apply EQ|apply LT|apply GT]; red; auto. - Defined. - - Definition eq_dec (s s':t) : { eq s s' } + { ~ eq s s' }. - Proof. - intros (s,b) (s',b'); unfold eq; simpl. - case_eq (Raw.equal s s'); intro H; [left|right]. - apply equal_2; auto. - intro H'; rewrite equal_1 in H; auto; discriminate. - Defined. - - (* specs *) - Section Specs. - Variable s s' s'': t. - Variable x y : elt. - - Hint Resolve is_bst. - - Lemma mem_1 : In x s -> mem x s = true. - Proof. exact (mem_1 (is_bst s)). Qed. - Lemma mem_2 : mem x s = true -> In x s. - Proof. exact (@mem_2 s x). Qed. - - Lemma equal_1 : Equal s s' -> equal s s' = true. - Proof. exact (equal_1 (is_bst s) (is_bst s')). Qed. - Lemma equal_2 : equal s s' = true -> Equal s s'. - Proof. exact (@equal_2 s s'). Qed. - - Ltac wrap t H := unfold t, In; simpl; rewrite H; auto; intuition. - - Lemma subset_1 : Subset s s' -> subset s s' = true. - Proof. wrap subset subset_12. Qed. - Lemma subset_2 : subset s s' = true -> Subset s s'. - Proof. wrap subset subset_12. Qed. - - Lemma empty_1 : Empty empty. - Proof. exact empty_1. Qed. - - Lemma is_empty_1 : Empty s -> is_empty s = true. - Proof. exact (@is_empty_1 s). Qed. - Lemma is_empty_2 : is_empty s = true -> Empty s. - Proof. exact (@is_empty_2 s). Qed. - - Lemma add_1 : E.eq x y -> In y (add x s). - Proof. wrap add add_in. Qed. - Lemma add_2 : In y s -> In y (add x s). - Proof. wrap add add_in. Qed. - Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. - Proof. wrap add add_in. elim H; auto. Qed. - - Lemma remove_1 : E.eq x y -> ~ In y (remove x s). - Proof. wrap remove remove_in. Qed. - Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). - Proof. wrap remove remove_in. Qed. - Lemma remove_3 : In y (remove x s) -> In y s. - Proof. wrap remove remove_in. Qed. - - Lemma singleton_1 : In y (singleton x) -> E.eq x y. - Proof. exact (@singleton_1 x y). Qed. - Lemma singleton_2 : E.eq x y -> In y (singleton x). - Proof. exact (@singleton_2 x y). Qed. - - Lemma union_1 : In x (union s s') -> In x s \/ In x s'. - Proof. wrap union union_in. Qed. - Lemma union_2 : In x s -> In x (union s s'). - Proof. wrap union union_in. Qed. - Lemma union_3 : In x s' -> In x (union s s'). - Proof. wrap union union_in. Qed. - - Lemma inter_1 : In x (inter s s') -> In x s. - Proof. wrap inter inter_in. Qed. - Lemma inter_2 : In x (inter s s') -> In x s'. - Proof. wrap inter inter_in. Qed. - Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). - Proof. wrap inter inter_in. Qed. - - Lemma diff_1 : In x (diff s s') -> In x s. - Proof. wrap diff diff_in. Qed. - Lemma diff_2 : In x (diff s s') -> ~ In x s'. - Proof. wrap diff diff_in. Qed. - Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - Proof. wrap diff diff_in. Qed. - - Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. unfold fold, elements; intros; apply fold_1; auto. Qed. - - Lemma cardinal_1 : cardinal s = length (elements s). - Proof. - unfold cardinal, elements; intros; apply elements_cardinal; auto. - Qed. - - Section Filter. - Variable f : elt -> bool. - - Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Proof. intro. wrap filter filter_in. Qed. - Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Proof. intro. wrap filter filter_in. Qed. - Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. intro. wrap filter filter_in. Qed. - - Lemma for_all_1 : compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. - Proof. exact (@for_all_1 f s). Qed. - Lemma for_all_2 : compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. - Proof. exact (@for_all_2 f s). Qed. - - Lemma exists_1 : compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. exact (@exists_1 f s). Qed. - Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. exact (@exists_2 f s). Qed. - - Lemma partition_1 : compat_bool E.eq f -> - Equal (fst (partition f s)) (filter f s). - Proof. - unfold partition, filter, Equal, In; simpl ;intros H a. - rewrite partition_in_1, filter_in; intuition. - Qed. - - Lemma partition_2 : compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - unfold partition, filter, Equal, In; simpl ;intros H a. - rewrite partition_in_2, filter_in; intuition. - rewrite H2; auto. - destruct (f a); auto. - red; intros; f_equal. - rewrite (H _ _ H0); auto. - Qed. - - End Filter. - - Lemma elements_1 : In x s -> InA E.eq x (elements s). - Proof. wrap elements elements_in. Qed. - Lemma elements_2 : InA E.eq x (elements s) -> In x s. - Proof. wrap elements elements_in. Qed. - Lemma elements_3 : sort E.lt (elements s). - Proof. exact (elements_sort (is_bst s)). Qed. - Lemma elements_3w : NoDupA E.eq (elements s). - Proof. exact (elements_nodup (is_bst s)). Qed. - - Lemma min_elt_1 : min_elt s = Some x -> In x s. - Proof. exact (@min_elt_1 s x). Qed. - Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. - Proof. exact (@min_elt_2 s x y (is_bst s)). Qed. - Lemma min_elt_3 : min_elt s = None -> Empty s. - Proof. exact (@min_elt_3 s). Qed. - - Lemma max_elt_1 : max_elt s = Some x -> In x s. - Proof. exact (@max_elt_1 s x). Qed. - Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. - Proof. exact (@max_elt_2 s x y (is_bst s)). Qed. - Lemma max_elt_3 : max_elt s = None -> Empty s. - Proof. exact (@max_elt_3 s). Qed. - - Lemma choose_1 : choose s = Some x -> In x s. - Proof. exact (@choose_1 s x). Qed. - Lemma choose_2 : choose s = None -> Empty s. - Proof. exact (@choose_2 s). Qed. - Lemma choose_3 : choose s = Some x -> choose s' = Some y -> - Equal s s' -> E.eq x y. - Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed. - - Lemma eq_refl : eq s s. - Proof. exact (eq_refl s). Qed. - Lemma eq_sym : eq s s' -> eq s' s. - Proof. exact (@eq_sym s s'). Qed. - Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''. - Proof. exact (@eq_trans s s' s''). Qed. - - Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''. - Proof. exact (@lt_trans s s' s''). Qed. - Lemma lt_not_eq : lt s s' -> ~eq s s'. - Proof. exact (@lt_not_eq _ _ (is_bst s) (is_bst s')). Qed. - - End Specs. + Module X' := OrdersAlt.Update_OT X. + Module MSet := MSetAVL.IntMake I X'. + Include FSetCompat.Backport_Sets X MSet. End IntMake. (* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index c03fb92e..7f8c51d6 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetBridge.v 11699 2008-12-18 11:49:08Z letouzey $ *) +(* $Id$ *) (** * Finite sets library *) @@ -23,51 +23,51 @@ Set Firstorder Depth 2. Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition empty : {s : t | Empty s}. - Proof. + Proof. exists empty; auto with set. Qed. Definition is_empty : forall s : t, {Empty s} + {~ Empty s}. - Proof. + Proof. intros; generalize (is_empty_1 (s:=s)) (is_empty_2 (s:=s)). case (is_empty s); intuition. Qed. Definition mem : forall (x : elt) (s : t), {In x s} + {~ In x s}. - Proof. + Proof. intros; generalize (mem_1 (s:=s) (x:=x)) (mem_2 (s:=s) (x:=x)). case (mem x s); intuition. Qed. - + Definition Add (x : elt) (s s' : t) := forall y : elt, In y s' <-> E.eq x y \/ In y s. - + Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}. Proof. intros; exists (add x s); auto. unfold Add in |- *; intuition. elim (E.eq_dec x y); auto. - intros; right. + intros; right. eapply add_3; eauto. - Qed. - + Qed. + Definition singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. - Proof. + Proof. intros; exists (singleton x); intuition. Qed. - + Definition remove : forall (x : elt) (s : t), {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. Proof. intros; exists (remove x s); intuition. absurd (In x (remove x s)); auto with set. - apply In_1 with y; auto. + apply In_1 with y; auto. elim (E.eq_dec x y); intros; auto. absurd (In x (remove x s)); auto with set. - apply In_1 with y; auto. + apply In_1 with y; auto. eauto with set. Qed. @@ -75,47 +75,47 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}. Proof. intros; exists (union s s'); intuition. - Qed. + Qed. Definition inter : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}. - Proof. + Proof. intros; exists (inter s s'); intuition; eauto with set. Qed. Definition diff : forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. - Proof. - intros; exists (diff s s'); intuition; eauto with set. - absurd (In x s'); eauto with set. - Qed. - + Proof. + intros; exists (diff s s'); intuition; eauto with set. + absurd (In x s'); eauto with set. + Qed. + Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}. - Proof. - intros. + Proof. + intros. generalize (equal_1 (s:=s) (s':=s')) (equal_2 (s:=s) (s':=s')). case (equal s s'); intuition. Qed. Definition subset : forall s s' : t, {Subset s s'} + {~Subset s s'}. - Proof. - intros. + Proof. + intros. generalize (subset_1 (s:=s) (s':=s')) (subset_2 (s:=s) (s':=s')). case (subset s s'); intuition. - Qed. + Qed. Definition elements : forall s : t, {l : list elt | sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}. Proof. - intros; exists (elements s); intuition. - Defined. + intros; exists (elements s); intuition. + Defined. Definition fold : forall (A : Type) (f : elt -> A -> A) (s : t) (i : A), - {r : A | let (l,_) := elements s in + {r : A | let (l,_) := elements s in r = fold_left (fun a e => f e a) l i}. - Proof. + Proof. intros; exists (fold (A:=A) f s i); exact (fold_1 s i f). Qed. @@ -124,16 +124,16 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. {r : nat | let (l,_) := elements s in r = length l }. Proof. intros; exists (cardinal s); exact (cardinal_1 s). - Qed. + Qed. Definition fdec (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) - (x : elt) := if Pdec x then true else false. + (x : elt) := if Pdec x then true else false. Lemma compat_P_aux : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}), compat_P E.eq P -> compat_bool E.eq (fdec Pdec). Proof. - unfold compat_P, compat_bool, fdec in |- *; intros. + unfold compat_P, compat_bool, Proper, respectful, fdec in |- *; intros. generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder. Qed. @@ -143,7 +143,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}. Proof. - intros. + intros. exists (filter (fdec Pdec) s). intro H; assert (compat_bool E.eq (fdec Pdec)); auto. intuition. @@ -160,29 +160,29 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition for_all : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. - Proof. - intros. + Proof. + intros. generalize (for_all_1 (s:=s) (f:=fdec Pdec)) (for_all_2 (s:=s) (f:=fdec Pdec)). case (for_all (fdec Pdec) s); unfold For_all in |- *; [ left | right ]; intros. assert (compat_bool E.eq (fdec Pdec)); auto. generalize (H0 H3 (refl_equal _) _ H2). - unfold fdec in |- *. + unfold fdec in |- *. case (Pdec x); intuition. inversion H4. - intuition. + intuition. absurd (false = true); [ auto with bool | apply H; auto ]. intro. - unfold fdec in |- *. + unfold fdec in |- *. case (Pdec x); intuition. Qed. Definition exists_ : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}. - Proof. - intros. + Proof. + intros. generalize (exists_1 (s:=s) (f:=fdec Pdec)) (exists_2 (s:=s) (f:=fdec Pdec)). case (exists_ (fdec Pdec) s); unfold Exists in |- *; [ left | right ]; @@ -190,14 +190,14 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. elim H0; auto; intros. exists x; intuition. generalize H4. - unfold fdec in |- *. + unfold fdec in |- *. case (Pdec x); intuition. inversion H2. - intuition. - elim H2; intros. + intuition. + elim H2; intros. absurd (false = true); [ auto with bool | apply H; auto ]. exists x; intuition. - unfold fdec in |- *. + unfold fdec in |- *. case (Pdec x); intuition. Qed. @@ -217,7 +217,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. intros s1 s2; simpl in |- *. intros; assert (compat_bool E.eq (fdec Pdec)); auto. intros; assert (compat_bool E.eq (fun x => negb (fdec Pdec x))). - generalize H2; unfold compat_bool in |- *; intuition; + generalize H2; unfold compat_bool, Proper, respectful in |- *; intuition; apply (f_equal negb); auto. intuition. generalize H4; unfold For_all, Equal in |- *; intuition. @@ -228,12 +228,12 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. inversion H9. generalize H; unfold For_all, Equal in |- *; intuition. elim (H0 x); intros. - cut ((fun x => negb (fdec Pdec x)) x = true). + cut ((fun x => negb (fdec Pdec x)) x = true). unfold fdec in |- *; case (Pdec x); intuition. change ((fun x => negb (fdec Pdec x)) x = true) in |- *. apply (filter_2 (s:=s) (x:=x)); auto. set (b := fdec Pdec x) in *; generalize (refl_equal b); - pattern b at -1 in |- *; case b; unfold b in |- *; + pattern b at -1 in |- *; case b; unfold b in |- *; [ left | right ]. elim (H4 x); intros _ B; apply B; auto with set. elim (H x); intros _ B; apply B; auto with set. @@ -242,16 +242,16 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B; auto. eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; auto. - Qed. + Qed. - Definition choose_aux: forall s : t, + Definition choose_aux: forall s : t, { x : elt | M.choose s = Some x } + { M.choose s = None }. Proof. intros. destruct (M.choose s); [left | right]; auto. exists e; auto. Qed. - + Definition choose : forall s : t, {x : elt | In x s} + {Empty s}. Proof. intros; destruct (choose_aux s) as [(x,Hx)|H]. @@ -259,12 +259,12 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. right; apply choose_2; auto. Defined. - Lemma choose_ok1 : - forall s x, M.choose s = Some x <-> exists H:In x s, + Lemma choose_ok1 : + forall s x, M.choose s = Some x <-> exists H:In x s, choose s = inleft _ (exist (fun x => In x s) x H). Proof. intros s x. - unfold choose; split; intros. + unfold choose; split; intros. destruct (choose_aux s) as [(y,Hy)|H']; try congruence. replace x with y in * by congruence. exists (choose_1 Hy); auto. @@ -272,10 +272,10 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. destruct (choose_aux s) as [(y,Hy)|H']; congruence. Qed. - Lemma choose_ok2 : - forall s, M.choose s = None <-> exists H:Empty s, + Lemma choose_ok2 : + forall s, M.choose s = None <-> exists H:Empty s, choose s = inright _ H. - Proof. + Proof. intros s. unfold choose; split; intros. destruct (choose_aux s) as [(y,Hy)|H']; try congruence. @@ -284,8 +284,8 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. destruct (choose_aux s) as [(y,Hy)|H']; congruence. Qed. - Lemma choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with + Lemma choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with | inleft (exist x _), inleft (exist x' _) => E.eq x x' | inright _, inright _ => True | _, _ => False @@ -306,29 +306,27 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition min_elt : forall s : t, {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}. - Proof. + Proof. intros; generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)). - case (min_elt s); [ left | right ]; auto. + case (min_elt s); [ left | right ]; auto. exists e; unfold For_all in |- *; eauto. - Qed. + Qed. Definition max_elt : forall s : t, {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}. - Proof. + Proof. intros; generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)). - case (max_elt s); [ left | right ]; auto. + case (max_elt s); [ left | right ]; auto. exists e; unfold For_all in |- *; eauto. - Qed. - - Module E := E. + Qed. Definition elt := elt. Definition t := t. - Definition In := In. + Definition In := In. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Empty s := forall a : elt, ~ In a s. @@ -336,7 +334,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. forall x : elt, In x s -> P x. Definition Exists (P : elt -> Prop) (s : t) := exists x : elt, In x s /\ P x. - + Definition eq_In := In_1. Definition eq := Equal. @@ -344,10 +342,12 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. Definition eq_refl := eq_refl. Definition eq_sym := eq_sym. Definition eq_trans := eq_trans. - Definition lt_trans := lt_trans. + Definition lt_trans := lt_trans. Definition lt_not_eq := lt_not_eq. Definition compare := compare. + Module E := E. + End DepOfNodep. @@ -386,7 +386,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Proof. intros; unfold mem in |- *; case (M.mem x s); auto. Qed. - + Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. Proof. intros s x; unfold mem in |- *; case (M.mem x s); auto. @@ -399,26 +399,26 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. if equal s s' then true else false. Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true. - Proof. + Proof. intros; unfold equal in |- *; case M.equal; intuition. - Qed. - + Qed. + Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'. - Proof. + Proof. intros s s'; unfold equal in |- *; case (M.equal s s'); intuition; inversion H. Qed. - + Definition subset (s s' : t) : bool := if subset s s' then true else false. Lemma subset_1 : forall s s' : t, Subset s s' -> subset s s' = true. - Proof. + Proof. intros; unfold subset in |- *; case M.subset; intuition. - Qed. - + Qed. + Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'. - Proof. + Proof. intros s s'; unfold subset in |- *; case (M.subset s s'); intuition; inversion H. Qed. @@ -441,34 +441,34 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. intro s; unfold choose in |- *; case (M.choose s); auto. simple destruct s0; intros; discriminate H. Qed. - - Lemma choose_3 : forall s s' x x', + + Lemma choose_3 : forall s s' x x', choose s = Some x -> choose s' = Some x' -> Equal s s' -> E.eq x x'. Proof. unfold choose; intros. generalize (M.choose_equal H1); clear H1. - destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; + destruct (M.choose s) as [(?,?)|?]; destruct (M.choose s') as [(?,?)|?]; simpl; auto; congruence. Qed. - Definition elements (s : t) : list elt := let (l, _) := elements s in l. - + Definition elements (s : t) : list elt := let (l, _) := elements s in l. + Lemma elements_1 : forall (s : t) (x : elt), In x s -> InA E.eq x (elements s). - Proof. + Proof. intros; unfold elements in |- *; case (M.elements s); firstorder. Qed. Lemma elements_2 : forall (s : t) (x : elt), InA E.eq x (elements s) -> In x s. - Proof. + Proof. intros s x; unfold elements in |- *; case (M.elements s); firstorder. Qed. - Lemma elements_3 : forall s : t, sort E.lt (elements s). - Proof. + Lemma elements_3 : forall s : t, sort E.lt (elements s). + Proof. intros; unfold elements in |- *; case (M.elements s); firstorder. Qed. Hint Resolve elements_3. - + Lemma elements_3w : forall s : t, NoDupA E.eq (elements s). Proof. auto. Qed. @@ -478,27 +478,27 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. | inright _ => None end. - Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. + Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. Proof. intros s x; unfold min_elt in |- *; case (M.min_elt s). simple destruct s0; intros; injection H; intros; subst; intuition. intros; discriminate H. - Qed. + Qed. Lemma min_elt_2 : - forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. + forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. Proof. intros s x y; unfold min_elt in |- *; case (M.min_elt s). unfold For_all in |- *; simple destruct s0; intros; injection H; intros; subst; firstorder. intros; discriminate H. - Qed. + Qed. Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s. Proof. intros s; unfold min_elt in |- *; case (M.min_elt s); auto. simple destruct s0; intros; discriminate H. - Qed. + Qed. Definition max_elt (s : t) : option elt := match max_elt s with @@ -506,27 +506,27 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. | inright _ => None end. - Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. + Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. Proof. intros s x; unfold max_elt in |- *; case (M.max_elt s). simple destruct s0; intros; injection H; intros; subst; intuition. intros; discriminate H. - Qed. + Qed. Lemma max_elt_2 : - forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. + forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. Proof. intros s x y; unfold max_elt in |- *; case (M.max_elt s). unfold For_all in |- *; simple destruct s0; intros; injection H; intros; subst; firstorder. intros; discriminate H. - Qed. + Qed. Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s. Proof. intros s; unfold max_elt in |- *; case (M.max_elt s); auto. simple destruct s0; intros; discriminate H. - Qed. + Qed. Definition add (x : elt) (s : t) : t := let (s', _) := add x s in s'. @@ -566,70 +566,70 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Proof. intros s x y; unfold remove in |- *; case (M.remove x s); firstorder. Qed. - - Definition singleton (x : elt) : t := let (s, _) := singleton x in s. - - Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y. + + Definition singleton (x : elt) : t := let (s, _) := singleton x in s. + + Lemma singleton_1 : forall x y : elt, In y (singleton x) -> E.eq x y. Proof. intros x y; unfold singleton in |- *; case (M.singleton x); firstorder. Qed. - Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x). + Lemma singleton_2 : forall x y : elt, E.eq x y -> In y (singleton x). Proof. intros x y; unfold singleton in |- *; case (M.singleton x); firstorder. Qed. - + Definition union (s s' : t) : t := let (s'', _) := union s s' in s''. - + Lemma union_1 : forall (s s' : t) (x : elt), In x (union s s') -> In x s \/ In x s'. - Proof. + Proof. intros s s' x; unfold union in |- *; case (M.union s s'); firstorder. Qed. - Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s'). - Proof. + Lemma union_2 : forall (s s' : t) (x : elt), In x s -> In x (union s s'). + Proof. intros s s' x; unfold union in |- *; case (M.union s s'); firstorder. Qed. Lemma union_3 : forall (s s' : t) (x : elt), In x s' -> In x (union s s'). - Proof. + Proof. intros s s' x; unfold union in |- *; case (M.union s s'); firstorder. Qed. Definition inter (s s' : t) : t := let (s'', _) := inter s s' in s''. - + Lemma inter_1 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s. - Proof. + Proof. intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder. Qed. Lemma inter_2 : forall (s s' : t) (x : elt), In x (inter s s') -> In x s'. - Proof. + Proof. intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder. Qed. Lemma inter_3 : forall (s s' : t) (x : elt), In x s -> In x s' -> In x (inter s s'). - Proof. + Proof. intros s s' x; unfold inter in |- *; case (M.inter s s'); firstorder. Qed. Definition diff (s s' : t) : t := let (s'', _) := diff s s' in s''. - + Lemma diff_1 : forall (s s' : t) (x : elt), In x (diff s s') -> In x s. - Proof. + Proof. intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. Qed. Lemma diff_2 : forall (s s' : t) (x : elt), In x (diff s s') -> ~ In x s'. - Proof. + Proof. intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. Qed. Lemma diff_3 : forall (s s' : t) (x : elt), In x s -> ~ In x s' -> In x (diff s s'). - Proof. + Proof. intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. Qed. @@ -637,36 +637,37 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Lemma cardinal_1 : forall s, cardinal s = length (elements s). Proof. - intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *; + intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *; destruct (M.elements s); auto. Qed. - Definition fold (B : Type) (f : elt -> B -> B) (i : t) + Definition fold (B : Type) (f : elt -> B -> B) (i : t) (s : B) : B := let (fold, _) := fold f i s in fold. Lemma fold_1 : forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. Proof. - intros; unfold fold in |- *; case (M.fold f s i); unfold elements in *; + intros; unfold fold in |- *; case (M.fold f s i); unfold elements in *; destruct (M.elements s); auto. - Qed. + Qed. Definition f_dec : forall (f : elt -> bool) (x : elt), {f x = true} + {f x <> true}. Proof. intros; case (f x); auto with bool. - Defined. + Defined. Lemma compat_P_aux : forall f : elt -> bool, compat_bool E.eq f -> compat_P E.eq (fun x => f x = true). Proof. - unfold compat_bool, compat_P in |- *; intros; rewrite <- H1; firstorder. + unfold compat_bool, compat_P, Proper, respectful, impl; intros; + rewrite <- H1; firstorder. Qed. Hint Resolve compat_P_aux. - + Definition filter (f : elt -> bool) (s : t) : t := let (s', _) := filter (P:=fun x => f x = true) (f_dec f) s in s'. @@ -680,7 +681,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Lemma filter_2 : forall (s : t) (x : elt) (f : elt -> bool), - compat_bool E.eq f -> In x (filter f s) -> f x = true. + compat_bool E.eq f -> In x (filter f s) -> f x = true. Proof. intros s x f; unfold filter in |- *; case M.filter; intuition. generalize (i (compat_P_aux H)); firstorder. @@ -688,7 +689,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Lemma filter_3 : forall (s : t) (x : elt) (f : elt -> bool), - compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). + compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). Proof. intros s x f; unfold filter in |- *; case M.filter; intuition. generalize (i (compat_P_aux H)); firstorder. @@ -697,98 +698,97 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Definition for_all (f : elt -> bool) (s : t) : bool := if for_all (P:=fun x => f x = true) (f_dec f) s then true - else false. + else false. Lemma for_all_1 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. - Proof. + Proof. intros s f; unfold for_all in |- *; case M.for_all; intuition; elim n; auto. Qed. - + Lemma for_all_2 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. - Proof. + Proof. intros s f; unfold for_all in |- *; case M.for_all; intuition; inversion H0. Qed. - + Definition exists_ (f : elt -> bool) (s : t) : bool := if exists_ (P:=fun x => f x = true) (f_dec f) s then true - else false. + else false. Lemma exists_1 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. + Proof. intros s f; unfold exists_ in |- *; case M.exists_; intuition; elim n; auto. Qed. - + Lemma exists_2 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. + Proof. intros s f; unfold exists_ in |- *; case M.exists_; intuition; inversion H0. Qed. - - Definition partition (f : elt -> bool) (s : t) : + + Definition partition (f : elt -> bool) (s : t) : t * t := let (p, _) := partition (P:=fun x => f x = true) (f_dec f) s in p. - + Lemma partition_1 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). Proof. - intros s f; unfold partition in |- *; case M.partition. - intro p; case p; clear p; intros s1 s2 H C. + intros s f; unfold partition in |- *; case M.partition. + intro p; case p; clear p; intros s1 s2 H C. generalize (H (compat_P_aux C)); clear H; intro H. simpl in |- *; unfold Equal in |- *; intuition. - apply filter_3; firstorder. - elim (H2 a); intros. - assert (In a s). + apply filter_3; firstorder. + elim (H2 a); intros. + assert (In a s). eapply filter_1; eauto. elim H3; intros; auto. absurd (f a = true). exact (H a H6). - eapply filter_2; eauto. - Qed. - + eapply filter_2; eauto. + Qed. + Lemma partition_2 : forall (s : t) (f : elt -> bool), compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). Proof. - intros s f; unfold partition in |- *; case M.partition. - intro p; case p; clear p; intros s1 s2 H C. + intros s f; unfold partition in |- *; case M.partition. + intro p; case p; clear p; intros s1 s2 H C. generalize (H (compat_P_aux C)); clear H; intro H. assert (D : compat_bool E.eq (fun x => negb (f x))). - generalize C; unfold compat_bool in |- *; intros; apply (f_equal negb); + generalize C; unfold compat_bool, Proper, respectful; intros; apply (f_equal negb); auto. simpl in |- *; unfold Equal in |- *; intuition. apply filter_3; firstorder. - elim (H2 a); intros. - assert (In a s). + elim (H2 a); intros. + assert (In a s). eapply filter_1; eauto. elim H3; intros; auto. absurd (f a = true). intro. - generalize (filter_2 D H1). + generalize (filter_2 D H1). rewrite H7; intros H8; inversion H8. exact (H0 a H6). - Qed. + Qed. - Module E := E. Definition elt := elt. Definition t := t. - Definition In := In. + Definition In := In. Definition Equal s s' := forall a : elt, In a s <-> In a s'. Definition Subset s s' := forall a : elt, In a s -> In a s'. Definition Add (x : elt) (s s' : t) := @@ -806,8 +806,10 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Definition eq_refl := eq_refl. Definition eq_sym := eq_sym. Definition eq_trans := eq_trans. - Definition lt_trans := lt_trans. + Definition lt_trans := lt_trans. Definition lt_not_eq := lt_not_eq. Definition compare := compare. + Module E := E. + End NodepOfDep. diff --git a/theories/FSets/FSetCompat.v b/theories/FSets/FSetCompat.v new file mode 100644 index 00000000..c3d614ee --- /dev/null +++ b/theories/FSets/FSetCompat.v @@ -0,0 +1,410 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(** * Compatibility functors between FSetInterface and MSetInterface. *) + +Require Import FSetInterface FSetFacts MSetInterface MSetFacts. +Set Implicit Arguments. +Unset Strict Implicit. + +(** * From new Weak Sets to old ones *) + +Module Backport_WSets + (E:DecidableType.DecidableType) + (M:MSetInterface.WSets with Definition E.t := E.t + with Definition E.eq := E.eq) + <: FSetInterface.WSfun E. + + Definition elt := E.t. + Definition t := M.t. + + Implicit Type s : t. + Implicit Type x y : elt. + Implicit Type f : elt -> bool. + + Definition In : elt -> t -> Prop := M.In. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + Definition empty : t := M.empty. + Definition is_empty : t -> bool := M.is_empty. + Definition mem : elt -> t -> bool := M.mem. + Definition add : elt -> t -> t := M.add. + Definition singleton : elt -> t := M.singleton. + Definition remove : elt -> t -> t := M.remove. + Definition union : t -> t -> t := M.union. + Definition inter : t -> t -> t := M.inter. + Definition diff : t -> t -> t := M.diff. + Definition eq : t -> t -> Prop := M.eq. + Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec. + Definition equal : t -> t -> bool := M.equal. + Definition subset : t -> t -> bool := M.subset. + Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold. + Definition for_all : (elt -> bool) -> t -> bool := M.for_all. + Definition exists_ : (elt -> bool) -> t -> bool := M.exists_. + Definition filter : (elt -> bool) -> t -> t := M.filter. + Definition partition : (elt -> bool) -> t -> t * t:= M.partition. + Definition cardinal : t -> nat := M.cardinal. + Definition elements : t -> list elt := M.elements. + Definition choose : t -> option elt := M.choose. + + Module MF := MSetFacts.WFacts M. + + Definition In_1 : forall s x y, E.eq x y -> In x s -> In y s + := MF.In_1. + Definition eq_refl : forall s, eq s s + := @Equivalence_Reflexive _ _ M.eq_equiv. + Definition eq_sym : forall s s', eq s s' -> eq s' s + := @Equivalence_Symmetric _ _ M.eq_equiv. + Definition eq_trans : forall s s' s'', eq s s' -> eq s' s'' -> eq s s'' + := @Equivalence_Transitive _ _ M.eq_equiv. + Definition mem_1 : forall s x, In x s -> mem x s = true + := MF.mem_1. + Definition mem_2 : forall s x, mem x s = true -> In x s + := MF.mem_2. + Definition equal_1 : forall s s', Equal s s' -> equal s s' = true + := MF.equal_1. + Definition equal_2 : forall s s', equal s s' = true -> Equal s s' + := MF.equal_2. + Definition subset_1 : forall s s', Subset s s' -> subset s s' = true + := MF.subset_1. + Definition subset_2 : forall s s', subset s s' = true -> Subset s s' + := MF.subset_2. + Definition empty_1 : Empty empty := MF.empty_1. + Definition is_empty_1 : forall s, Empty s -> is_empty s = true + := MF.is_empty_1. + Definition is_empty_2 : forall s, is_empty s = true -> Empty s + := MF.is_empty_2. + Definition add_1 : forall s x y, E.eq x y -> In y (add x s) + := MF.add_1. + Definition add_2 : forall s x y, In y s -> In y (add x s) + := MF.add_2. + Definition add_3 : forall s x y, ~ E.eq x y -> In y (add x s) -> In y s + := MF.add_3. + Definition remove_1 : forall s x y, E.eq x y -> ~ In y (remove x s) + := MF.remove_1. + Definition remove_2 : forall s x y, ~ E.eq x y -> In y s -> In y (remove x s) + := MF.remove_2. + Definition remove_3 : forall s x y, In y (remove x s) -> In y s + := MF.remove_3. + Definition union_1 : forall s s' x, In x (union s s') -> In x s \/ In x s' + := MF.union_1. + Definition union_2 : forall s s' x, In x s -> In x (union s s') + := MF.union_2. + Definition union_3 : forall s s' x, In x s' -> In x (union s s') + := MF.union_3. + Definition inter_1 : forall s s' x, In x (inter s s') -> In x s + := MF.inter_1. + Definition inter_2 : forall s s' x, In x (inter s s') -> In x s' + := MF.inter_2. + Definition inter_3 : forall s s' x, In x s -> In x s' -> In x (inter s s') + := MF.inter_3. + Definition diff_1 : forall s s' x, In x (diff s s') -> In x s + := MF.diff_1. + Definition diff_2 : forall s s' x, In x (diff s s') -> ~ In x s' + := MF.diff_2. + Definition diff_3 : forall s s' x, In x s -> ~ In x s' -> In x (diff s s') + := MF.diff_3. + Definition singleton_1 : forall x y, In y (singleton x) -> E.eq x y + := MF.singleton_1. + Definition singleton_2 : forall x y, E.eq x y -> In y (singleton x) + := MF.singleton_2. + Definition fold_1 : forall s (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i + := MF.fold_1. + Definition cardinal_1 : forall s, cardinal s = length (elements s) + := MF.cardinal_1. + Definition filter_1 : forall s x f, compat_bool E.eq f -> + In x (filter f s) -> In x s + := MF.filter_1. + Definition filter_2 : forall s x f, compat_bool E.eq f -> + In x (filter f s) -> f x = true + := MF.filter_2. + Definition filter_3 : forall s x f, compat_bool E.eq f -> + In x s -> f x = true -> In x (filter f s) + := MF.filter_3. + Definition for_all_1 : forall s f, compat_bool E.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true + := MF.for_all_1. + Definition for_all_2 : forall s f, compat_bool E.eq f -> + for_all f s = true -> For_all (fun x => f x = true) s + := MF.for_all_2. + Definition exists_1 : forall s f, compat_bool E.eq f -> + Exists (fun x => f x = true) s -> exists_ f s = true + := MF.exists_1. + Definition exists_2 : forall s f, compat_bool E.eq f -> + exists_ f s = true -> Exists (fun x => f x = true) s + := MF.exists_2. + Definition partition_1 : forall s f, compat_bool E.eq f -> + Equal (fst (partition f s)) (filter f s) + := MF.partition_1. + Definition partition_2 : forall s f, compat_bool E.eq f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) + := MF.partition_2. + Definition choose_1 : forall s x, choose s = Some x -> In x s + := MF.choose_1. + Definition choose_2 : forall s, choose s = None -> Empty s + := MF.choose_2. + Definition elements_1 : forall s x, In x s -> InA E.eq x (elements s) + := MF.elements_1. + Definition elements_2 : forall s x, InA E.eq x (elements s) -> In x s + := MF.elements_2. + Definition elements_3w : forall s, NoDupA E.eq (elements s) + := MF.elements_3w. + +End Backport_WSets. + + +(** * From new Sets to new ones *) + +Module Backport_Sets + (E:OrderedType.OrderedType) + (M:MSetInterface.Sets with Definition E.t := E.t + with Definition E.eq := E.eq + with Definition E.lt := E.lt) + <: FSetInterface.S with Module E:=E. + + Include Backport_WSets E M. + + Implicit Type s : t. + Implicit Type x y : elt. + + Definition lt : t -> t -> Prop := M.lt. + Definition min_elt : t -> option elt := M.min_elt. + Definition max_elt : t -> option elt := M.max_elt. + Definition min_elt_1 : forall s x, min_elt s = Some x -> In x s + := M.min_elt_spec1. + Definition min_elt_2 : forall s x y, + min_elt s = Some x -> In y s -> ~ E.lt y x + := M.min_elt_spec2. + Definition min_elt_3 : forall s, min_elt s = None -> Empty s + := M.min_elt_spec3. + Definition max_elt_1 : forall s x, max_elt s = Some x -> In x s + := M.max_elt_spec1. + Definition max_elt_2 : forall s x y, + max_elt s = Some x -> In y s -> ~ E.lt x y + := M.max_elt_spec2. + Definition max_elt_3 : forall s, max_elt s = None -> Empty s + := M.max_elt_spec3. + Definition elements_3 : forall s, sort E.lt (elements s) + := M.elements_spec2. + Definition choose_3 : forall s s' x y, + choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y + := M.choose_spec3. + Definition lt_trans : forall s s' s'', lt s s' -> lt s' s'' -> lt s s'' + := @StrictOrder_Transitive _ _ M.lt_strorder. + Lemma lt_not_eq : forall s s', lt s s' -> ~ eq s s'. + Proof. + unfold lt, eq. intros s s' Hlt Heq. rewrite Heq in Hlt. + apply (StrictOrder_Irreflexive s'); auto. + Qed. + Definition compare : forall s s', Compare lt eq s s'. + Proof. + intros s s'; destruct (CompSpec2Type (M.compare_spec s s')); + [ apply EQ | apply LT | apply GT ]; auto. + Defined. + + Module E := E. + +End Backport_Sets. + + +(** * From old Weak Sets to new ones. *) + +Module Update_WSets + (E:Equalities.DecidableType) + (M:FSetInterface.WS with Definition E.t := E.t + with Definition E.eq := E.eq) + <: MSetInterface.WSetsOn E. + + Definition elt := E.t. + Definition t := M.t. + + Implicit Type s : t. + Implicit Type x y : elt. + Implicit Type f : elt -> bool. + + Definition In : elt -> t -> Prop := M.In. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + Definition empty : t := M.empty. + Definition is_empty : t -> bool := M.is_empty. + Definition mem : elt -> t -> bool := M.mem. + Definition add : elt -> t -> t := M.add. + Definition singleton : elt -> t := M.singleton. + Definition remove : elt -> t -> t := M.remove. + Definition union : t -> t -> t := M.union. + Definition inter : t -> t -> t := M.inter. + Definition diff : t -> t -> t := M.diff. + Definition eq : t -> t -> Prop := M.eq. + Definition eq_dec : forall s s', {eq s s'}+{~eq s s'}:= M.eq_dec. + Definition equal : t -> t -> bool := M.equal. + Definition subset : t -> t -> bool := M.subset. + Definition fold : forall A : Type, (elt -> A -> A) -> t -> A -> A := M.fold. + Definition for_all : (elt -> bool) -> t -> bool := M.for_all. + Definition exists_ : (elt -> bool) -> t -> bool := M.exists_. + Definition filter : (elt -> bool) -> t -> t := M.filter. + Definition partition : (elt -> bool) -> t -> t * t:= M.partition. + Definition cardinal : t -> nat := M.cardinal. + Definition elements : t -> list elt := M.elements. + Definition choose : t -> option elt := M.choose. + + Module MF := FSetFacts.WFacts M. + + Instance In_compat : Proper (E.eq==>Logic.eq==>iff) In. + Proof. intros x x' Hx s s' Hs. subst. apply MF.In_eq_iff; auto. Qed. + + Instance eq_equiv : Equivalence eq. + + Section Spec. + Variable s s': t. + Variable x y : elt. + + Lemma mem_spec : mem x s = true <-> In x s. + Proof. intros; symmetry; apply MF.mem_iff. Qed. + + Lemma equal_spec : equal s s' = true <-> Equal s s'. + Proof. intros; symmetry; apply MF.equal_iff. Qed. + + Lemma subset_spec : subset s s' = true <-> Subset s s'. + Proof. intros; symmetry; apply MF.subset_iff. Qed. + + Definition empty_spec : Empty empty := M.empty_1. + + Lemma is_empty_spec : is_empty s = true <-> Empty s. + Proof. intros; symmetry; apply MF.is_empty_iff. Qed. + + Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s. + Proof. intros. rewrite MF.add_iff. intuition. Qed. + + Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. + Proof. intros. rewrite MF.remove_iff. intuition. Qed. + + Lemma singleton_spec : In y (singleton x) <-> E.eq y x. + Proof. intros; rewrite MF.singleton_iff. intuition. Qed. + + Definition union_spec : In x (union s s') <-> In x s \/ In x s' + := @MF.union_iff s s' x. + Definition inter_spec : In x (inter s s') <-> In x s /\ In x s' + := @MF.inter_iff s s' x. + Definition diff_spec : In x (diff s s') <-> In x s /\ ~In x s' + := @MF.diff_iff s s' x. + Definition fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i + := @M.fold_1 s. + Definition cardinal_spec : cardinal s = length (elements s) + := @M.cardinal_1 s. + + Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s. + Proof. intros; symmetry; apply MF.elements_iff. Qed. + + Definition elements_spec2w : NoDupA E.eq (elements s) + := @M.elements_3w s. + Definition choose_spec1 : choose s = Some x -> In x s + := @M.choose_1 s x. + Definition choose_spec2 : choose s = None -> Empty s + := @M.choose_2 s. + Definition filter_spec : forall f, Proper (E.eq==>Logic.eq) f -> + (In x (filter f s) <-> In x s /\ f x = true) + := @MF.filter_iff s x. + Definition partition_spec1 : forall f, Proper (E.eq==>Logic.eq) f -> + Equal (fst (partition f s)) (filter f s) + := @M.partition_1 s. + Definition partition_spec2 : forall f, Proper (E.eq==>Logic.eq) f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s) + := @M.partition_2 s. + + Lemma for_all_spec : forall f, Proper (E.eq==>Logic.eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. intros; symmetry; apply MF.for_all_iff; auto. Qed. + + Lemma exists_spec : forall f, Proper (E.eq==>Logic.eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. intros; symmetry; apply MF.exists_iff; auto. Qed. + + End Spec. + +End Update_WSets. + + +(** * From old Sets to new ones. *) + +Module Update_Sets + (E:Orders.OrderedType) + (M:FSetInterface.S with Definition E.t := E.t + with Definition E.eq := E.eq + with Definition E.lt := E.lt) + <: MSetInterface.Sets with Module E:=E. + + Include Update_WSets E M. + + Implicit Type s : t. + Implicit Type x y : elt. + + Definition lt : t -> t -> Prop := M.lt. + Definition min_elt : t -> option elt := M.min_elt. + Definition max_elt : t -> option elt := M.max_elt. + Definition min_elt_spec1 : forall s x, min_elt s = Some x -> In x s + := M.min_elt_1. + Definition min_elt_spec2 : forall s x y, + min_elt s = Some x -> In y s -> ~ E.lt y x + := M.min_elt_2. + Definition min_elt_spec3 : forall s, min_elt s = None -> Empty s + := M.min_elt_3. + Definition max_elt_spec1 : forall s x, max_elt s = Some x -> In x s + := M.max_elt_1. + Definition max_elt_spec2 : forall s x y, + max_elt s = Some x -> In y s -> ~ E.lt x y + := M.max_elt_2. + Definition max_elt_spec3 : forall s, max_elt s = None -> Empty s + := M.max_elt_3. + Definition elements_spec2 : forall s, sort E.lt (elements s) + := M.elements_3. + Definition choose_spec3 : forall s s' x y, + choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y + := M.choose_3. + + Instance lt_strorder : StrictOrder lt. + Proof. + split. + intros x Hx. apply (M.lt_not_eq Hx); auto with *. + exact M.lt_trans. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + intros s s' Hs u u' Hu H. + assert (H0 : lt s' u). + destruct (M.compare s' u) as [H'|H'|H']; auto. + elim (M.lt_not_eq H). transitivity s'; auto with *. + elim (M.lt_not_eq (M.lt_trans H H')); auto. + destruct (M.compare s' u') as [H'|H'|H']; auto. + elim (M.lt_not_eq H). + transitivity u'; auto with *. transitivity s'; auto with *. + elim (M.lt_not_eq (M.lt_trans H' H0)); auto with *. + Qed. + + Definition compare s s' := + match M.compare s s' with + | EQ _ => Eq + | LT _ => Lt + | GT _ => Gt + end. + + Lemma compare_spec : forall s s', CompSpec eq lt s s' (compare s s'). + Proof. intros; unfold compare; destruct M.compare; auto. Qed. + + Module E := E. + +End Update_Sets. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index f84d8f58..b7d6382e 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetDecide.v 13199 2010-06-25 22:36:22Z letouzey $ *) +(* $Id$ *) (**************************************************************) (* FSetDecide.v *) @@ -148,35 +148,35 @@ the above form: XXX: This tactic and the similar subsequent ones should have been defined using [autorewrite]. However, dealing - with multiples rewrite sites and side-conditions is - done more cleverly with the following explicit + with multiples rewrite sites and side-conditions is + done more cleverly with the following explicit analysis of goals. *) - Ltac or_not_l_iff P Q tac := - (rewrite (or_not_l_iff_1 P Q) by tac) || + Ltac or_not_l_iff P Q tac := + (rewrite (or_not_l_iff_1 P Q) by tac) || (rewrite (or_not_l_iff_2 P Q) by tac). - Ltac or_not_r_iff P Q tac := - (rewrite (or_not_r_iff_1 P Q) by tac) || + Ltac or_not_r_iff P Q tac := + (rewrite (or_not_r_iff_1 P Q) by tac) || (rewrite (or_not_r_iff_2 P Q) by tac). - Ltac or_not_l_iff_in P Q H tac := - (rewrite (or_not_l_iff_1 P Q) in H by tac) || + Ltac or_not_l_iff_in P Q H tac := + (rewrite (or_not_l_iff_1 P Q) in H by tac) || (rewrite (or_not_l_iff_2 P Q) in H by tac). - Ltac or_not_r_iff_in P Q H tac := - (rewrite (or_not_r_iff_1 P Q) in H by tac) || + Ltac or_not_r_iff_in P Q H tac := + (rewrite (or_not_r_iff_1 P Q) in H by tac) || (rewrite (or_not_r_iff_2 P Q) in H by tac). Tactic Notation "push" "not" "using" ident(db) := - let dec := solve_decidable using db in + let dec := solve_decidable using db in unfold not, iff; repeat ( match goal with | |- context [True -> False] => rewrite not_true_iff | |- context [False -> False] => rewrite not_false_iff | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec - | |- context [(?P -> False) -> (?Q -> False)] => + | |- context [(?P -> False) -> (?Q -> False)] => rewrite (contrapositive P Q) by dec | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec @@ -192,23 +192,23 @@ the above form: Tactic Notation "push" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in + let dec := solve_decidable using db in unfold not, iff in * |-; repeat ( match goal with | H: context [True -> False] |- _ => rewrite not_true_iff in H | H: context [False -> False] |- _ => rewrite not_false_iff in H - | H: context [(?P -> False) -> False] |- _ => + | H: context [(?P -> False) -> False] |- _ => rewrite (not_not_iff P) in H by dec | H: context [(?P -> False) -> (?Q -> False)] |- _ => rewrite (contrapositive P Q) in H by dec | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec - | H: context [(?P -> False) -> ?Q] |- _ => + | H: context [(?P -> False) -> ?Q] |- _ => rewrite (imp_not_l P Q) in H by dec | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H - | H: context [(?P -> ?Q) -> False] |- _ => + | H: context [(?P -> ?Q) -> False] |- _ => rewrite (not_imp_iff P Q) in H by dec end); fold any not. @@ -253,7 +253,7 @@ the above form: the hypotheses and goal together. *) Tactic Notation "pull" "not" "using" ident(db) := - let dec := solve_decidable using db in + let dec := solve_decidable using db in unfold not, iff; repeat ( match goal with @@ -269,7 +269,7 @@ the above form: rewrite <- (not_or_iff P Q) | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec - | |- context [(?Q -> False) /\ ?P] => + | |- context [(?Q -> False) /\ ?P] => rewrite <- (not_imp_rev_iff P Q) by dec end); fold any not. @@ -279,7 +279,7 @@ the above form: Tactic Notation "pull" "not" "in" "*" "|-" "using" ident(db) := - let dec := solve_decidable using db in + let dec := solve_decidable using db in unfold not, iff in * |-; repeat ( match goal with @@ -294,8 +294,8 @@ the above form: | H: context [(?P -> False) -> ?Q] |- _ => rewrite (imp_not_l P Q) in H by dec | H: context [(?P -> False) /\ (?Q -> False)] |- _ => - rewrite <- (not_or_iff P Q) in H - | H: context [?P -> ?Q -> False] |- _ => + rewrite <- (not_or_iff P Q) in H + | H: context [?P -> ?Q -> False] |- _ => rewrite <- (not_and_iff P Q) in H | H: context [?P /\ (?Q -> False)] |- _ => rewrite <- (not_imp_iff P Q) in H by dec @@ -673,13 +673,13 @@ the above form: Ltac fsetdec := (** We first unfold any occurrences of [iff]. *) unfold iff in *; - (** We remove dependencies to logical hypothesis. This way, - later "clear" will work nicely (see bug #2136) *) - no_logical_interdep; (** We fold occurrences of [not] because it is better for [intros] to leave us with a goal of [~ P] than a goal of [False]. *) fold any not; intros; + (** We remove dependencies to logical hypothesis. This way, + later "clear" will work nicely (see bug #2136) *) + no_logical_interdep; (** Now we decompose conjunctions, which will allow the [discard_nonFSet] and [assert_decidability] tactics to do a much better job. *) diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index 80ab2b2c..ec0c6a55 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -6,15 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetEqProperties.v 11720 2008-12-28 07:12:15Z letouzey $ *) +(* $Id$ *) (** * Finite sets library *) -(** This module proves many properties of finite sets that - are consequences of the axiomatization in [FsetInterface] - Contrary to the functor in [FsetProperties] it uses +(** This module proves many properties of finite sets that + are consequences of the axiomatization in [FsetInterface] + Contrary to the functor in [FsetProperties] it uses sets operations instead of predicates over sets, i.e. - [mem x s=true] instead of [In x s], + [mem x s=true] instead of [In x s], [equal s s'=true] instead of [Equal s s'], etc. *) Require Import FSetProperties Zerob Sumbool Omega DecidableTypeEx. @@ -26,59 +26,59 @@ Import M. Definition Add := MP.Add. -Section BasicProperties. +Section BasicProperties. -(** Some old specifications written with boolean equalities. *) +(** Some old specifications written with boolean equalities. *) Variable s s' s'': t. Variable x y z : elt. -Lemma mem_eq: +Lemma mem_eq: E.eq x y -> mem x s=mem y s. -Proof. +Proof. intro H; rewrite H; auto. Qed. -Lemma equal_mem_1: +Lemma equal_mem_1: (forall a, mem a s=mem a s') -> equal s s'=true. -Proof. +Proof. intros; apply equal_1; unfold Equal; intros. do 2 rewrite mem_iff; rewrite H; tauto. Qed. -Lemma equal_mem_2: +Lemma equal_mem_2: equal s s'=true -> forall a, mem a s=mem a s'. -Proof. +Proof. intros; rewrite (equal_2 H); auto. Qed. -Lemma subset_mem_1: +Lemma subset_mem_1: (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. -Proof. +Proof. intros; apply subset_1; unfold Subset; intros a. do 2 rewrite mem_iff; auto. Qed. -Lemma subset_mem_2: +Lemma subset_mem_2: subset s s'=true -> forall a, mem a s=true -> mem a s'=true. -Proof. +Proof. intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. Qed. - + Lemma empty_mem: mem x empty=false. -Proof. +Proof. rewrite <- not_mem_iff; auto with set. Qed. Lemma is_empty_equal_empty: is_empty s = equal s empty. -Proof. +Proof. apply bool_1; split; intros. auto with set. rewrite <- is_empty_iff; auto with set. Qed. - + Lemma choose_mem_1: choose s=Some x -> mem x s=true. -Proof. +Proof. auto with set. Qed. @@ -90,44 +90,44 @@ Qed. Lemma add_mem_1: mem x (add x s)=true. Proof. auto with set. -Qed. - +Qed. + Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. -Proof. +Proof. apply add_neq_b. Qed. Lemma remove_mem_1: mem x (remove x s)=false. -Proof. +Proof. rewrite <- not_mem_iff; auto with set. -Qed. - +Qed. + Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. -Proof. +Proof. apply remove_neq_b. Qed. -Lemma singleton_equal_add: +Lemma singleton_equal_add: equal (singleton x) (add x empty)=true. Proof. rewrite (singleton_equal_add x); auto with set. -Qed. +Qed. -Lemma union_mem: +Lemma union_mem: mem x (union s s')=mem x s || mem x s'. -Proof. +Proof. apply union_b. Qed. -Lemma inter_mem: +Lemma inter_mem: mem x (inter s s')=mem x s && mem x s'. -Proof. +Proof. apply inter_b. Qed. -Lemma diff_mem: +Lemma diff_mem: mem x (diff s s')=mem x s && negb (mem x s'). -Proof. +Proof. apply diff_b. Qed. @@ -143,7 +143,7 @@ Proof. intros; rewrite not_mem_iff; auto. Qed. -(** Properties of [equal] *) +(** Properties of [equal] *) Lemma equal_refl: equal s s=true. Proof. @@ -155,19 +155,19 @@ Proof. intros; apply bool_1; do 2 rewrite <- equal_iff; intuition. Qed. -Lemma equal_trans: +Lemma equal_trans: equal s s'=true -> equal s' s''=true -> equal s s''=true. Proof. intros; rewrite (equal_2 H); auto. Qed. -Lemma equal_equal: +Lemma equal_equal: equal s s'=true -> equal s s''=equal s' s''. Proof. intros; rewrite (equal_2 H); auto. Qed. -Lemma equal_cardinal: +Lemma equal_cardinal: equal s s'=true -> cardinal s=cardinal s'. Proof. auto with set. @@ -175,25 +175,25 @@ Qed. (* Properties of [subset] *) -Lemma subset_refl: subset s s=true. +Lemma subset_refl: subset s s=true. Proof. auto with set. Qed. -Lemma subset_antisym: +Lemma subset_antisym: subset s s'=true -> subset s' s=true -> equal s s'=true. Proof. auto with set. Qed. -Lemma subset_trans: +Lemma subset_trans: subset s s'=true -> subset s' s''=true -> subset s s''=true. Proof. do 3 rewrite <- subset_iff; intros. apply subset_trans with s'; auto. Qed. -Lemma subset_equal: +Lemma subset_equal: equal s s'=true -> subset s s'=true. Proof. auto with set. @@ -201,7 +201,7 @@ Qed. (** Properties of [choose] *) -Lemma choose_mem_3: +Lemma choose_mem_3: is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. Proof. intros. @@ -221,13 +221,13 @@ Qed. (** Properties of [add] *) -Lemma add_mem_3: +Lemma add_mem_3: mem y s=true -> mem y (add x s)=true. Proof. auto with set. Qed. -Lemma add_equal: +Lemma add_equal: mem x s=true -> equal (add x s) s=true. Proof. auto with set. @@ -235,26 +235,26 @@ Qed. (** Properties of [remove] *) -Lemma remove_mem_3: +Lemma remove_mem_3: mem y (remove x s)=true -> mem y s=true. Proof. rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. Qed. -Lemma remove_equal: +Lemma remove_equal: mem x s=false -> equal (remove x s) s=true. Proof. intros; apply equal_1; apply remove_equal. rewrite not_mem_iff; auto. Qed. -Lemma add_remove: +Lemma add_remove: mem x s=true -> equal (add x (remove x s)) s=true. Proof. intros; apply equal_1; apply add_remove; auto with set. Qed. -Lemma remove_add: +Lemma remove_add: mem x s=false -> equal (remove x (add x s)) s=true. Proof. intros; apply equal_1; apply remove_add; auto. @@ -297,37 +297,37 @@ Proof. auto with set. Qed. -Lemma union_subset_equal: +Lemma union_subset_equal: subset s s'=true -> equal (union s s') s'=true. Proof. auto with set. Qed. -Lemma union_equal_1: +Lemma union_equal_1: equal s s'=true-> equal (union s s'') (union s' s'')=true. Proof. auto with set. Qed. -Lemma union_equal_2: +Lemma union_equal_2: equal s' s''=true-> equal (union s s') (union s s'')=true. Proof. auto with set. Qed. -Lemma union_assoc: +Lemma union_assoc: equal (union (union s s') s'') (union s (union s' s''))=true. Proof. auto with set. Qed. -Lemma add_union_singleton: +Lemma add_union_singleton: equal (add x s) (union (singleton x) s)=true. Proof. auto with set. Qed. -Lemma union_add: +Lemma union_add: equal (union (add x s) s') (add x (union s s'))=true. Proof. auto with set. @@ -346,62 +346,62 @@ auto with set. Qed. Lemma union_subset_3: - subset s s''=true -> subset s' s''=true -> + subset s s''=true -> subset s' s''=true -> subset (union s s') s''=true. Proof. intros; apply subset_1; apply union_subset_3; auto with set. Qed. -(** Properties of [inter] *) +(** Properties of [inter] *) Lemma inter_sym: equal (inter s s') (inter s' s)=true. Proof. auto with set. Qed. -Lemma inter_subset_equal: +Lemma inter_subset_equal: subset s s'=true -> equal (inter s s') s=true. Proof. auto with set. Qed. -Lemma inter_equal_1: +Lemma inter_equal_1: equal s s'=true -> equal (inter s s'') (inter s' s'')=true. Proof. auto with set. Qed. -Lemma inter_equal_2: +Lemma inter_equal_2: equal s' s''=true -> equal (inter s s') (inter s s'')=true. Proof. auto with set. Qed. -Lemma inter_assoc: +Lemma inter_assoc: equal (inter (inter s s') s'') (inter s (inter s' s''))=true. Proof. auto with set. Qed. -Lemma union_inter_1: +Lemma union_inter_1: equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. Proof. auto with set. Qed. -Lemma union_inter_2: +Lemma union_inter_2: equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. Proof. auto with set. Qed. -Lemma inter_add_1: mem x s'=true -> +Lemma inter_add_1: mem x s'=true -> equal (inter (add x s) s') (add x (inter s s'))=true. Proof. auto with set. Qed. -Lemma inter_add_2: mem x s'=false -> +Lemma inter_add_2: mem x s'=false -> equal (inter (add x s) s') (inter s s')=true. Proof. intros; apply equal_1; apply inter_add_2. @@ -421,7 +421,7 @@ auto with set. Qed. Lemma inter_subset_3: - subset s'' s=true -> subset s'' s'=true -> + subset s'' s=true -> subset s'' s'=true -> subset s'' (inter s s')=true. Proof. intros; apply subset_1; apply inter_subset_3; auto with set. @@ -440,19 +440,19 @@ Proof. auto with set. Qed. -Lemma remove_inter_singleton: +Lemma remove_inter_singleton: equal (remove x s) (diff s (singleton x))=true. Proof. auto with set. Qed. Lemma diff_inter_empty: - equal (inter (diff s s') (inter s s')) empty=true. + equal (inter (diff s s') (inter s s')) empty=true. Proof. auto with set. Qed. -Lemma diff_inter_all: +Lemma diff_inter_all: equal (union (diff s s') (inter s s')) s=true. Proof. auto with set. @@ -462,7 +462,7 @@ End BasicProperties. Hint Immediate empty_mem is_empty_equal_empty add_mem_1 remove_mem_1 singleton_equal_add union_mem inter_mem - diff_mem equal_sym add_remove remove_add : set. + diff_mem equal_sym add_remove remove_add : set. Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal subset_refl subset_equal subset_antisym @@ -472,8 +472,8 @@ Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 (** General recursion principle *) Lemma set_rec: forall (P:t->Type), - (forall s s', equal s s'=true -> P s -> P s') -> - (forall s x, mem x s=false -> P s -> P (add x s)) -> + (forall s s', equal s s'=true -> P s -> P s') -> + (forall s x, mem x s=false -> P s -> P (add x s)) -> P empty -> forall s, P s. Proof. intros. @@ -493,51 +493,51 @@ intros; do 2 rewrite mem_iff. destruct (mem x s); destruct (mem x s'); intuition. Qed. -Section Fold. +Section Fold. Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). Variables (i:A). Variables (s s':t)(x:elt). - + Lemma fold_empty: (fold f empty i) = i. -Proof. +Proof. apply fold_empty; auto. Qed. -Lemma fold_equal: +Lemma fold_equal: equal s s'=true -> eqA (fold f s i) (fold f s' i). -Proof. +Proof. intros; apply fold_equal with (eqA:=eqA); auto with set. Qed. - -Lemma fold_add: + +Lemma fold_add: mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). -Proof. +Proof. intros; apply fold_add with (eqA:=eqA); auto. rewrite not_mem_iff; auto. Qed. -Lemma add_fold: +Lemma add_fold: mem x s=true -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply add_fold with (eqA:=eqA); auto with set. Qed. -Lemma remove_fold_1: +Lemma remove_fold_1: mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). Proof. intros; apply remove_fold_1 with (eqA:=eqA); auto with set. Qed. -Lemma remove_fold_2: +Lemma remove_fold_2: mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros; apply remove_fold_2 with (eqA:=eqA); auto. rewrite not_mem_iff; auto. Qed. -Lemma fold_union: - (forall x, mem x s && mem x s'=false) -> +Lemma fold_union: + (forall x, mem x s && mem x s'=false) -> eqA (fold f (union s s') i) (fold f s (fold f s' i)). Proof. intros; apply fold_union with (eqA:=eqA); auto. @@ -548,40 +548,40 @@ End Fold. (** Properties of [cardinal] *) -Lemma add_cardinal_1: +Lemma add_cardinal_1: forall s x, mem x s=true -> cardinal (add x s)=cardinal s. Proof. auto with set. Qed. -Lemma add_cardinal_2: +Lemma add_cardinal_2: forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). Proof. intros; apply add_cardinal_2; auto. rewrite not_mem_iff; auto. Qed. -Lemma remove_cardinal_1: +Lemma remove_cardinal_1: forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. Proof. intros; apply remove_cardinal_1; auto with set. Qed. -Lemma remove_cardinal_2: +Lemma remove_cardinal_2: forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. Proof. intros; apply Equal_cardinal; apply equal_2; auto with set. Qed. -Lemma union_cardinal: - forall s s', (forall x, mem x s && mem x s'=false) -> +Lemma union_cardinal: + forall s s', (forall x, mem x s && mem x s'=false) -> cardinal (union s s')=cardinal s+cardinal s'. Proof. intros; apply union_cardinal; auto; intros. rewrite exclusive_set; auto. Qed. -Lemma subset_cardinal: +Lemma subset_cardinal: forall s s', subset s s'=true -> cardinal s<=cardinal s'. Proof. intros; apply subset_cardinal; auto with set. @@ -592,24 +592,24 @@ Section Bool. (** Properties of [filter] *) Variable f:elt->bool. -Variable Comp: compat_bool E.eq f. +Variable Comp: Proper (E.eq==>Logic.eq) f. -Let Comp' : compat_bool E.eq (fun x =>negb (f x)). +Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)). Proof. -unfold compat_bool in *; intros; f_equal; auto. +repeat red; intros; f_equal; auto. Qed. Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. -Proof. +Proof. intros; apply filter_b; auto. Qed. -Lemma for_all_filter: +Lemma for_all_filter: forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). -Proof. +Proof. intros; apply bool_1; split; intros. apply is_empty_1. -unfold Empty; intros. +unfold Empty; intros. rewrite filter_iff; auto. red; destruct 1. rewrite <- (@for_all_iff s f) in H; auto. @@ -621,10 +621,10 @@ rewrite filter_iff; auto. destruct (f x); auto. Qed. -Lemma exists_filter : +Lemma exists_filter : forall s, exists_ f s=negb (is_empty (filter f s)). -Proof. -intros; apply bool_1; split; intros. +Proof. +intros; apply bool_1; split; intros. destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). apply bool_6. red; intros; apply (@is_empty_2 _ H0 a); auto with set. @@ -636,28 +636,28 @@ intros _ H0. rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate. Qed. -Lemma partition_filter_1: +Lemma partition_filter_1: forall s, equal (fst (partition f s)) (filter f s)=true. -Proof. +Proof. auto with set. Qed. -Lemma partition_filter_2: +Lemma partition_filter_2: forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. -Proof. +Proof. auto with set. Qed. -Lemma filter_add_1 : forall s x, f x = true -> - filter f (add x s) [=] add x (filter f s). +Lemma filter_add_1 : forall s x, f x = true -> + filter f (add x s) [=] add x (filter f s). Proof. red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. intuition. rewrite <- H; apply Comp; auto. Qed. -Lemma filter_add_2 : forall s x, f x = false -> - filter f (add x s) [=] filter f s. +Lemma filter_add_2 : forall s x, f x = false -> + filter f (add x s) [=] filter f s. Proof. red; intros; do 2 (rewrite filter_iff; auto); set_iff. intuition. @@ -665,18 +665,18 @@ assert (f x = f a) by (apply Comp; auto). rewrite H in H1; rewrite H2 in H1; discriminate. Qed. -Lemma add_filter_1 : forall s s' x, +Lemma add_filter_1 : forall s s' x, f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). Proof. unfold Add, MP.Add; intros. repeat rewrite filter_iff; auto. rewrite H0; clear H0. -assert (E.eq x y -> f y = true) by +assert (E.eq x y -> f y = true) by (intro H0; rewrite <- (Comp _ _ H0); auto). tauto. Qed. -Lemma add_filter_2 : forall s s' x, +Lemma add_filter_2 : forall s s' x, f x=false -> (Add x s s') -> filter f s [=] filter f s'. Proof. unfold Add, MP.Add, Equal; intros. @@ -686,7 +686,7 @@ assert (f a = true -> ~E.eq x a). intros H0 H1. rewrite (Comp _ _ H1) in H. rewrite H in H0; discriminate. -tauto. +tauto. Qed. Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) -> @@ -695,7 +695,7 @@ Proof. clear Comp' Comp f. intros. assert (compat_bool E.eq (fun x => orb (f x) (g x))). - unfold compat_bool; intros. + unfold compat_bool, Proper, respectful; intros. rewrite (H x y H1); rewrite (H0 x y H1); auto. unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. assert (f a || g a = true <-> f a = true \/ g a = true). @@ -711,7 +711,7 @@ Qed. (** Properties of [for_all] *) -Lemma for_all_mem_1: forall s, +Lemma for_all_mem_1: forall s, (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. Proof. intros. @@ -724,8 +724,8 @@ generalize (H a); case (mem a s);intros;auto. rewrite H0;auto. Qed. -Lemma for_all_mem_2: forall s, - (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. +Lemma for_all_mem_2: forall s, + (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. Proof. intros. rewrite for_all_filter in H; auto. @@ -734,10 +734,10 @@ generalize (equal_mem_2 _ _ H x). rewrite filter_b; auto. rewrite empty_mem. rewrite H0; simpl;intros. -replace true with (negb false);auto;apply negb_sym;auto. +rewrite <- negb_false_iff; auto. Qed. -Lemma for_all_mem_3: +Lemma for_all_mem_3: forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. Proof. intros. @@ -752,7 +752,7 @@ rewrite H0. simpl;auto. Qed. -Lemma for_all_mem_4: +Lemma for_all_mem_4: forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. Proof. intros. @@ -762,12 +762,12 @@ exists x. rewrite filter_b in H1; auto. elim (andb_prop _ _ H1). split;auto. -replace false with (negb true);auto;apply negb_sym;auto. +rewrite <- negb_true_iff; auto. Qed. (** Properties of [exists] *) -Lemma for_all_exists: +Lemma for_all_exists: forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). Proof. intros. @@ -785,49 +785,49 @@ Variable Comp: compat_bool E.eq f. Let Comp' : compat_bool E.eq (fun x =>negb (f x)). Proof. -unfold compat_bool in *; intros; f_equal; auto. +unfold compat_bool, Proper, respectful in *; intros; f_equal; auto. Qed. -Lemma exists_mem_1: +Lemma exists_mem_1: forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. Proof. intros. rewrite for_all_exists; auto. rewrite for_all_mem_1;auto with bool. -intros;generalize (H x H0);intros. -symmetry;apply negb_sym;simpl;auto. +intros;generalize (H x H0);intros. +rewrite negb_true_iff; auto. Qed. -Lemma exists_mem_2: - forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. +Lemma exists_mem_2: + forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. Proof. intros. rewrite for_all_exists in H; auto. -replace false with (negb true);auto;apply negb_sym;symmetry. -rewrite (for_all_mem_2 (fun x => negb (f x)) Comp' s);simpl;auto. -replace true with (negb false);auto;apply negb_sym;auto. +rewrite negb_false_iff in H. +rewrite <- negb_true_iff. +apply for_all_mem_2 with (2:=H); auto. Qed. -Lemma exists_mem_3: +Lemma exists_mem_3: forall s x, mem x s=true -> f x=true -> exists_ f s=true. Proof. intros. rewrite for_all_exists; auto. -symmetry;apply negb_sym;simpl. +rewrite negb_true_iff. apply for_all_mem_3 with x;auto. -rewrite H0;auto. +rewrite negb_false_iff; auto. Qed. -Lemma exists_mem_4: +Lemma exists_mem_4: forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. Proof. intros. rewrite for_all_exists in H; auto. -elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros. +rewrite negb_true_iff in H. +elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros;auto. elim p;intros. exists x;split;auto. -replace true with (negb false);auto;apply negb_sym;auto. -replace false with (negb true);auto;apply negb_sym;auto. +rewrite <-negb_false_iff; auto. Qed. End Bool'. @@ -836,21 +836,21 @@ Section Sum. (** Adding a valuation function on all elements of a set. *) -Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. -Notation compat_opL := (compat_op E.eq (@Logic.eq _)). -Notation transposeL := (transpose (@Logic.eq _)). +Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. +Notation compat_opL := (compat_op E.eq Logic.eq). +Notation transposeL := (transpose Logic.eq). -Lemma sum_plus : - forall f g, compat_nat E.eq f -> compat_nat E.eq g -> +Lemma sum_plus : + forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. Proof. unfold sum. intros f g Hf Hg. -assert (fc : compat_opL (fun x:elt =>plus (f x))). auto. +assert (fc : compat_opL (fun x:elt =>plus (f x))). red; auto. assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros; omega. -assert (gc : compat_opL (fun x:elt => plus (g x))). auto. +assert (gc : compat_opL (fun x:elt => plus (g x))). red; auto. assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega. -assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). auto. +assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). repeat red; auto. assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega. assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). intros s;pattern s; apply set_rec. @@ -863,14 +863,14 @@ rewrite H0;simpl;omega. do 3 rewrite fold_empty;auto. Qed. -Lemma sum_filter : forall f, (compat_bool E.eq f) -> +Lemma sum_filter : forall f, (compat_bool E.eq f) -> forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). Proof. unfold sum; intros f Hf. assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). -assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). - red; intros. - rewrite (Hf x x' H); auto. +assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). + repeat red; intros. + rewrite (Hf _ _ H); auto. assert (ct : transposeL (fun x => plus (if f x then 1 else 0))). red; intros; omega. intros s;pattern s; apply set_rec. @@ -891,12 +891,12 @@ unfold Empty; intros. rewrite filter_iff; auto; set_iff; tauto. Qed. -Lemma fold_compat : +Lemma fold_compat : forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) (f g:elt->A->A), - (compat_op E.eq eqA f) -> (transpose eqA f) -> - (compat_op E.eq eqA g) -> (transpose eqA g) -> - forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> + (compat_op E.eq eqA f) -> (transpose eqA f) -> + (compat_op E.eq eqA g) -> (transpose eqA g) -> + forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> (eqA (fold f s i) (fold g s i)). Proof. intros A eqA st f g fc ft gc gt i. @@ -912,17 +912,18 @@ transitivity (f x (fold f s0 i)). apply fold_add with (eqA:=eqA); auto with set. transitivity (g x (fold f s0 i)); auto with set. transitivity (g x (fold g s0 i)); auto with set. +apply gc; auto with *. symmetry; apply fold_add with (eqA:=eqA); auto. do 2 rewrite fold_empty; reflexivity. Qed. -Lemma sum_compat : - forall f g, compat_nat E.eq f -> compat_nat E.eq g -> +Lemma sum_compat : + forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. intros. -unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto. -red; intros; omega. -red; intros; omega. +unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto with *. +intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. +intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. Qed. End Sum. diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v index 674caaac..b750edfc 100644 --- a/theories/FSets/FSetFacts.v +++ b/theories/FSets/FSetFacts.v @@ -6,13 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetFacts.v 12187 2009-06-13 19:36:59Z msozeau $ *) +(* $Id$ *) (** * Finite sets library *) (** This functor derives additional facts from [FSetInterface.S]. These - facts are mainly the specifications of [FSetInterface.S] written using - different styles: equivalence and boolean equalities. + facts are mainly the specifications of [FSetInterface.S] written using + different styles: equivalence and boolean equalities. Moreover, we prove that [E.Eq] and [Equal] are setoid equalities. *) @@ -30,7 +30,7 @@ Definition eqb x y := if eq_dec x y then true else false. (** * Specifications written using equivalences *) -Section IffSpec. +Section IffSpec. Variable s s' s'' : t. Variable x y z : elt. @@ -50,12 +50,12 @@ rewrite mem_iff; destruct (mem x s); intuition. Qed. Lemma equal_iff : s[=]s' <-> equal s s' = true. -Proof. +Proof. split; [apply equal_1|apply equal_2]. Qed. Lemma subset_iff : s[<=]s' <-> subset s s' = true. -Proof. +Proof. split; [apply subset_1|apply subset_2]. Qed. @@ -64,8 +64,8 @@ Proof. intuition; apply (empty_1 H). Qed. -Lemma is_empty_iff : Empty s <-> is_empty s = true. -Proof. +Lemma is_empty_iff : Empty s <-> is_empty s = true. +Proof. split; [apply is_empty_1|apply is_empty_2]. Qed. @@ -75,7 +75,7 @@ split; [apply singleton_1|apply singleton_2]. Qed. Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. -Proof. +Proof. split; [ | destruct 1; [apply add_1|apply add_2]]; auto. destruct (eq_dec x y) as [E|E]; auto. intro H; right; exact (add_3 E H). @@ -116,8 +116,8 @@ Qed. Variable f : elt->bool. Lemma filter_iff : compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true). -Proof. -split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. +Proof. +split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. Qed. Lemma for_all_iff : compat_bool E.eq f -> @@ -125,7 +125,7 @@ Lemma for_all_iff : compat_bool E.eq f -> Proof. split; [apply for_all_1 | apply for_all_2]; auto. Qed. - + Lemma exists_iff : compat_bool E.eq f -> (Exists (fun x => f x = true) s <-> exists_ f s = true). Proof. @@ -133,17 +133,17 @@ split; [apply exists_1 | apply exists_2]; auto. Qed. Lemma elements_iff : In x s <-> InA E.eq x (elements s). -Proof. +Proof. split; [apply elements_1 | apply elements_2]. Qed. End IffSpec. (** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) - -Ltac set_iff := + +Ltac set_iff := repeat (progress ( - rewrite add_iff || rewrite remove_iff || rewrite singleton_iff + rewrite add_iff || rewrite remove_iff || rewrite singleton_iff || rewrite union_iff || rewrite inter_iff || rewrite diff_iff || rewrite empty_iff)). @@ -154,7 +154,7 @@ Variable s s' s'' : t. Variable x y z : elt. Lemma mem_b : E.eq x y -> mem x s = mem y s. -Proof. +Proof. intros. generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). destruct (mem x s); destruct (mem y s); intuition. @@ -191,7 +191,7 @@ destruct (mem y s); destruct (mem y (remove x s)); intuition. Qed. Lemma singleton_b : mem y (singleton x) = eqb x y. -Proof. +Proof. generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. Qed. @@ -236,7 +236,7 @@ Qed. Variable f : elt->bool. Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x. -Proof. +Proof. intros. generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. @@ -264,7 +264,7 @@ rewrite H2. rewrite InA_alt; eauto. Qed. -Lemma exists_b : compat_bool E.eq f -> +Lemma exists_b : compat_bool E.eq f -> exists_ f s = existsb f (elements s). Proof. intros. @@ -291,39 +291,27 @@ End BoolSpec. (** * [E.eq] and [Equal] are setoid equalities *) -Definition E_ST : Equivalence E.eq. +Instance E_ST : Equivalence E.eq. Proof. constructor ; red; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. Qed. -Definition Equal_ST : Equivalence Equal. -Proof. +Instance Equal_ST : Equivalence Equal. +Proof. constructor ; red; [apply eq_refl | apply eq_sym | apply eq_trans]. Qed. -Add Relation elt E.eq - reflexivity proved by E.eq_refl - symmetry proved by E.eq_sym - transitivity proved by E.eq_trans - as EltSetoid. - -Add Relation t Equal - reflexivity proved by eq_refl - symmetry proved by eq_sym - transitivity proved by eq_trans - as EqualSetoid. - -Add Morphism In with signature E.eq ==> Equal ==> iff as In_m. +Instance In_m : Proper (E.eq ==> Equal ==> iff) In. Proof. unfold Equal; intros x y H s s' H0. rewrite (In_eq_iff s H); auto. Qed. -Add Morphism is_empty : is_empty_m. +Instance is_empty_m : Proper (Equal==> Logic.eq) is_empty. Proof. unfold Equal; intros s s' H. generalize (is_empty_iff s)(is_empty_iff s'). -destruct (is_empty s); destruct (is_empty s'); +destruct (is_empty s); destruct (is_empty s'); unfold Empty; auto; intros. symmetry. rewrite <- H1; intros a Ha. @@ -336,12 +324,12 @@ destruct H1 as (_,H1). exact (H1 (refl_equal true) _ Ha). Qed. -Add Morphism Empty with signature Equal ==> iff as Empty_m. +Instance Empty_m : Proper (Equal ==> iff) Empty. Proof. -intros; do 2 rewrite is_empty_iff; rewrite H; intuition. +repeat red; intros; do 2 rewrite is_empty_iff; rewrite H; intuition. Qed. -Add Morphism mem : mem_m. +Instance mem_m : Proper (E.eq ==> Equal ==> Logic.eq) mem. Proof. unfold Equal; intros x y H s s' H0. generalize (H0 x); clear H0; rewrite (In_eq_iff s' H). @@ -349,7 +337,7 @@ generalize (mem_iff s x)(mem_iff s' y). destruct (mem x s); destruct (mem y s'); intuition. Qed. -Add Morphism singleton : singleton_m. +Instance singleton_m : Proper (E.eq ==> Equal) singleton. Proof. unfold Equal; intros x y H a. do 2 rewrite singleton_iff; split; intros. @@ -357,51 +345,51 @@ apply E.eq_trans with x; auto. apply E.eq_trans with y; auto. Qed. -Add Morphism add : add_m. +Instance add_m : Proper (E.eq==>Equal==>Equal) add. Proof. unfold Equal; intros x y H s s' H0 a. do 2 rewrite add_iff; rewrite H; rewrite H0; intuition. Qed. -Add Morphism remove : remove_m. +Instance remove_m : Proper (E.eq==>Equal==>Equal) remove. Proof. unfold Equal; intros x y H s s' H0 a. do 2 rewrite remove_iff; rewrite H; rewrite H0; intuition. Qed. -Add Morphism union : union_m. +Instance union_m : Proper (Equal==>Equal==>Equal) union. Proof. unfold Equal; intros s s' H s'' s''' H0 a. do 2 rewrite union_iff; rewrite H; rewrite H0; intuition. Qed. -Add Morphism inter : inter_m. +Instance inter_m : Proper (Equal==>Equal==>Equal) inter. Proof. unfold Equal; intros s s' H s'' s''' H0 a. do 2 rewrite inter_iff; rewrite H; rewrite H0; intuition. Qed. -Add Morphism diff : diff_m. +Instance diff_m : Proper (Equal==>Equal==>Equal) diff. Proof. unfold Equal; intros s s' H s'' s''' H0 a. do 2 rewrite diff_iff; rewrite H; rewrite H0; intuition. Qed. -Add Morphism Subset with signature Equal ==> Equal ==> iff as Subset_m. -Proof. +Instance Subset_m : Proper (Equal==>Equal==>iff) Subset. +Proof. unfold Equal, Subset; firstorder. Qed. -Add Morphism subset : subset_m. +Instance subset_m : Proper (Equal ==> Equal ==> Logic.eq) subset. Proof. intros s s' H s'' s''' H0. -generalize (subset_iff s s'') (subset_iff s' s'''). +generalize (subset_iff s s'') (subset_iff s' s'''). destruct (subset s s''); destruct (subset s' s'''); auto; intros. rewrite H in H1; rewrite H0 in H1; intuition. rewrite H in H1; rewrite H0 in H1; intuition. Qed. -Add Morphism equal : equal_m. +Instance equal_m : Proper (Equal ==> Equal ==> Logic.eq) equal. Proof. intros s s' H s'' s''' H0. generalize (equal_iff s s'') (equal_iff s' s'''). @@ -424,7 +412,7 @@ Add Relation t Subset transitivity proved by Subset_trans as SubsetSetoid. -Instance In_s_m : Morphisms.Morphism (E.eq ==> Subset ++> Basics.impl) In | 1. +Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> Basics.impl) In | 1. Proof. simpl_relation. eauto with set. Qed. @@ -467,7 +455,7 @@ Qed. (* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism without additional hypothesis on [f]. For instance: *) -Lemma filter_equal : forall f, compat_bool E.eq f -> +Lemma filter_equal : forall f, compat_bool E.eq f -> forall s s', s[=]s' -> filter f s [=] filter f s'. Proof. unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. @@ -478,10 +466,10 @@ Lemma filter_ext : forall f f', compat_bool E.eq f -> (forall x, f x = f' x) -> Proof. intros f f' Hf Hff' s s' Hss' x. do 2 (rewrite filter_iff; auto). rewrite Hff', Hss'; intuition. -red; intros; rewrite <- 2 Hff'; auto. +repeat red; intros; rewrite <- 2 Hff'; auto. Qed. -Lemma filter_subset : forall f, compat_bool E.eq f -> +Lemma filter_subset : forall f, compat_bool E.eq f -> forall s s', s[<=]s' -> filter f s [<=] filter f s'. Proof. unfold Subset; intros; rewrite filter_iff in *; intuition. diff --git a/theories/FSets/FSetFullAVL.v b/theories/FSets/FSetFullAVL.v deleted file mode 100644 index a2d8e681..00000000 --- a/theories/FSets/FSetFullAVL.v +++ /dev/null @@ -1,1133 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre - * Institution: LRI, CNRS UMR 8623 - Université Paris Sud - * 91405 Orsay, France *) - -(* $Id: FSetFullAVL.v 11699 2008-12-18 11:49:08Z letouzey $ *) - -(** * FSetFullAVL - - This file contains some complements to [FSetAVL]. - - - Functor [AvlProofs] proves that trees of [FSetAVL] are not only - binary search trees, but moreover well-balanced ones. This is done - by proving that all operations preserve the balancing. - - - Functor [OcamlOps] contains variants of [union], [subset], - [compare] and [equal] that are faithful to the original ocaml codes, - while the versions in FSetAVL have been adapted to perform only - structural recursive code. - - - Finally, we pack the previous elements in a [Make] functor - similar to the one of [FSetAVL], but richer. -*) - -Require Import Recdef FSetInterface FSetList ZArith Int FSetAVL. - -Set Implicit Arguments. -Unset Strict Implicit. - -Module AvlProofs (Import I:Int)(X:OrderedType). -Module Import Raw := Raw I X. -Import Raw.Proofs. -Module Import II := MoreInt I. -Open Local Scope pair_scope. -Open Local Scope Int_scope. - -(** * AVL trees *) - -(** [avl s] : [s] is a properly balanced AVL tree, - i.e. for any node the heights of the two children - differ by at most 2 *) - -Inductive avl : tree -> Prop := - | RBLeaf : avl Leaf - | RBNode : forall x l r h, avl l -> avl r -> - -(2) <= height l - height r <= 2 -> - h = max (height l) (height r) + 1 -> - avl (Node l x r h). - -(** * Automation and dedicated tactics *) - -Hint Constructors avl. - -(** A tactic for cleaning hypothesis after use of functional induction. *) - -Ltac clearf := - match goal with - | H : (@Logic.eq (Compare _ _ _ _) _ _) |- _ => clear H; clearf - | H : (@Logic.eq (sumbool _ _) _ _) |- _ => clear H; clearf - | _ => idtac - end. - -(** Tactics about [avl] *) - -Lemma height_non_negative : forall s : tree, avl s -> height s >= 0. -Proof. - induction s; simpl; intros; auto with zarith. - inv avl; intuition; omega_max. -Qed. -Implicit Arguments height_non_negative. - -(** When [H:avl r], typing [avl_nn H] or [avl_nn r] adds [height r>=0] *) - -Ltac avl_nn_hyp H := - let nz := fresh "nz" in assert (nz := height_non_negative H). - -Ltac avl_nn h := - let t := type of h in - match type of t with - | Prop => avl_nn_hyp h - | _ => match goal with H : avl h |- _ => avl_nn_hyp H end - end. - -(* Repeat the previous tactic. - Drawback: need to clear the [avl _] hyps ... Thank you Ltac *) - -Ltac avl_nns := - match goal with - | H:avl _ |- _ => avl_nn_hyp H; clear H; avl_nns - | _ => idtac - end. - -(** Results about [height] *) - -Lemma height_0 : forall s, avl s -> height s = 0 -> s = Leaf. -Proof. - destruct 1; intuition; simpl in *. - avl_nns; simpl in *; elimtype False; omega_max. -Qed. - -(** * Results about [avl] *) - -Lemma avl_node : - forall x l r, avl l -> avl r -> - -(2) <= height l - height r <= 2 -> - avl (Node l x r (max (height l) (height r) + 1)). -Proof. - intros; auto. -Qed. -Hint Resolve avl_node. - - -(** empty *) - -Lemma empty_avl : avl empty. -Proof. - auto. -Qed. - -(** singleton *) - -Lemma singleton_avl : forall x : elt, avl (singleton x). -Proof. - unfold singleton; intro. - constructor; auto; try red; simpl; omega_max. -Qed. - -(** create *) - -Lemma create_avl : - forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - avl (create l x r). -Proof. - unfold create; auto. -Qed. - -Lemma create_height : - forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - height (create l x r) = max (height l) (height r) + 1. -Proof. - unfold create; auto. -Qed. - -(** bal *) - -Lemma bal_avl : forall l x r, avl l -> avl r -> - -(3) <= height l - height r <= 3 -> avl (bal l x r). -Proof. - intros l x r; functional induction bal l x r; intros; clearf; - inv avl; simpl in *; - match goal with |- avl (assert_false _ _ _) => avl_nns - | _ => repeat apply create_avl; simpl in *; auto - end; omega_max. -Qed. - -Lemma bal_height_1 : forall l x r, avl l -> avl r -> - -(3) <= height l - height r <= 3 -> - 0 <= height (bal l x r) - max (height l) (height r) <= 1. -Proof. - intros l x r; functional induction bal l x r; intros; clearf; - inv avl; avl_nns; simpl in *; omega_max. -Qed. - -Lemma bal_height_2 : - forall l x r, avl l -> avl r -> -(2) <= height l - height r <= 2 -> - height (bal l x r) == max (height l) (height r) +1. -Proof. - intros l x r; functional induction bal l x r; intros; clearf; - inv avl; simpl in *; omega_max. -Qed. - -Ltac omega_bal := match goal with - | H:avl ?l, H':avl ?r |- context [ bal ?l ?x ?r ] => - generalize (bal_height_1 x H H') (bal_height_2 x H H'); - omega_max - end. - -(** add *) - -Lemma add_avl_1 : forall s x, avl s -> - avl (add x s) /\ 0 <= height (add x s) - height s <= 1. -Proof. - intros s x; functional induction (add x s); subst;intros; inv avl; simpl in *. - intuition; try constructor; simpl; auto; try omega_max. - (* LT *) - destruct IHt; auto. - split. - apply bal_avl; auto; omega_max. - omega_bal. - (* EQ *) - intuition; omega_max. - (* GT *) - destruct IHt; auto. - split. - apply bal_avl; auto; omega_max. - omega_bal. -Qed. - -Lemma add_avl : forall s x, avl s -> avl (add x s). -Proof. - intros; destruct (add_avl_1 x H); auto. -Qed. -Hint Resolve add_avl. - -(** join *) - -Lemma join_avl_1 : forall l x r, avl l -> avl r -> avl (join l x r) /\ - 0<= height (join l x r) - max (height l) (height r) <= 1. -Proof. - join_tac. - - split; simpl; auto. - destruct (add_avl_1 x H0). - avl_nns; omega_max. - set (l:=Node ll lx lr lh) in *. - split; auto. - destruct (add_avl_1 x H). - simpl (height Leaf). - avl_nns; omega_max. - - inversion_clear H. - assert (height (Node rl rx rr rh) = rh); auto. - set (r := Node rl rx rr rh) in *; clearbody r. - destruct (Hlr x r H2 H0); clear Hrl Hlr. - set (j := join lr x r) in *; clearbody j. - simpl. - assert (-(3) <= height ll - height j <= 3) by omega_max. - split. - apply bal_avl; auto. - omega_bal. - - inversion_clear H0. - assert (height (Node ll lx lr lh) = lh); auto. - set (l := Node ll lx lr lh) in *; clearbody l. - destruct (Hrl H H1); clear Hrl Hlr. - set (j := join l x rl) in *; clearbody j. - simpl. - assert (-(3) <= height j - height rr <= 3) by omega_max. - split. - apply bal_avl; auto. - omega_bal. - - clear Hrl Hlr. - assert (height (Node ll lx lr lh) = lh); auto. - assert (height (Node rl rx rr rh) = rh); auto. - set (l := Node ll lx lr lh) in *; clearbody l. - set (r := Node rl rx rr rh) in *; clearbody r. - assert (-(2) <= height l - height r <= 2) by omega_max. - split. - apply create_avl; auto. - rewrite create_height; auto; omega_max. -Qed. - -Lemma join_avl : forall l x r, avl l -> avl r -> avl (join l x r). -Proof. - intros; destruct (join_avl_1 x H H0); auto. -Qed. -Hint Resolve join_avl. - -(** remove_min *) - -Lemma remove_min_avl_1 : forall l x r h, avl (Node l x r h) -> - avl (remove_min l x r)#1 /\ - 0 <= height (Node l x r h) - height (remove_min l x r)#1 <= 1. -Proof. - intros l x r; functional induction (remove_min l x r); subst;simpl in *; intros. - inv avl; simpl in *; split; auto. - avl_nns; omega_max. - inversion_clear H. - rewrite e0 in IHp;simpl in IHp;destruct (IHp _x); auto. - split; simpl in *. - apply bal_avl; auto; omega_max. - omega_bal. -Qed. - -Lemma remove_min_avl : forall l x r h, avl (Node l x r h) -> - avl (remove_min l x r)#1. -Proof. - intros; destruct (remove_min_avl_1 H); auto. -Qed. - -(** merge *) - -Lemma merge_avl_1 : forall s1 s2, avl s1 -> avl s2 -> - -(2) <= height s1 - height s2 <= 2 -> - avl (merge s1 s2) /\ - 0<= height (merge s1 s2) - max (height s1) (height s2) <=1. -Proof. - intros s1 s2; functional induction (merge s1 s2); intros; - try factornode _x _x0 _x1 _x2 as s1. - simpl; split; auto; avl_nns; omega_max. - simpl; split; auto; avl_nns; simpl in *; omega_max. - generalize (remove_min_avl_1 H0). - rewrite e1; destruct 1. - split. - apply bal_avl; auto. - simpl; omega_max. - simpl in *; omega_bal. -Qed. - -Lemma merge_avl : forall s1 s2, avl s1 -> avl s2 -> - -(2) <= height s1 - height s2 <= 2 -> avl (merge s1 s2). -Proof. - intros; destruct (merge_avl_1 H H0 H1); auto. -Qed. - - -(** remove *) - -Lemma remove_avl_1 : forall s x, avl s -> - avl (remove x s) /\ 0 <= height s - height (remove x s) <= 1. -Proof. - intros s x; functional induction (remove x s); intros. - intuition; omega_max. - (* LT *) - inv avl. - destruct (IHt H0). - split. - apply bal_avl; auto. - omega_max. - omega_bal. - (* EQ *) - inv avl. - generalize (merge_avl_1 H0 H1 H2). - intuition omega_max. - (* GT *) - inv avl. - destruct (IHt H1). - split. - apply bal_avl; auto. - omega_max. - omega_bal. -Qed. - -Lemma remove_avl : forall s x, avl s -> avl (remove x s). -Proof. - intros; destruct (remove_avl_1 x H); auto. -Qed. -Hint Resolve remove_avl. - -(** concat *) - -Lemma concat_avl : forall s1 s2, avl s1 -> avl s2 -> avl (concat s1 s2). -Proof. - intros s1 s2; functional induction (concat s1 s2); auto. - intros; apply join_avl; auto. - generalize (remove_min_avl H0); rewrite e1; simpl; auto. -Qed. -Hint Resolve concat_avl. - -(** split *) - -Lemma split_avl : forall s x, avl s -> - avl (split x s)#l /\ avl (split x s)#r. -Proof. - intros s x; functional induction (split x s); simpl; auto. - rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. - simpl; inversion_clear 1; auto. - rewrite e1 in IHt;simpl in IHt;inversion_clear 1; intuition. -Qed. - -(** inter *) - -Lemma inter_avl : forall s1 s2, avl s1 -> avl s2 -> avl (inter s1 s2). -Proof. - intros s1 s2; functional induction inter s1 s2; auto; intros A1 A2; - generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; - inv avl; auto. -Qed. - -(** diff *) - -Lemma diff_avl : forall s1 s2, avl s1 -> avl s2 -> avl (diff s1 s2). -Proof. - intros s1 s2; functional induction diff s1 s2; auto; intros A1 A2; - generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; - inv avl; auto. -Qed. - -(** union *) - -Lemma union_avl : forall s1 s2, avl s1 -> avl s2 -> avl (union s1 s2). -Proof. - intros s1 s2; functional induction union s1 s2; auto; intros A1 A2; - generalize (split_avl x1 A2); rewrite e1; simpl; destruct 1; - inv avl; auto. -Qed. - -(** filter *) - -Lemma filter_acc_avl : forall f s acc, avl s -> avl acc -> - avl (filter_acc f acc s). -Proof. - induction s; simpl; auto. - intros. - inv avl. - destruct (f t); auto. -Qed. -Hint Resolve filter_acc_avl. - -Lemma filter_avl : forall f s, avl s -> avl (filter f s). -Proof. - unfold filter; intros; apply filter_acc_avl; auto. -Qed. - -(** partition *) - -Lemma partition_acc_avl_1 : forall f s acc, avl s -> - avl acc#1 -> avl (partition_acc f acc s)#1. -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. - inv avl. - apply IHs2; auto. - apply IHs1; auto. - destruct (f t); simpl; auto. -Qed. - -Lemma partition_acc_avl_2 : forall f s acc, avl s -> - avl acc#2 -> avl (partition_acc f acc s)#2. -Proof. - induction s; simpl; auto. - destruct acc as [acct accf]; simpl in *. - intros. - inv avl. - apply IHs2; auto. - apply IHs1; auto. - destruct (f t); simpl; auto. -Qed. - -Lemma partition_avl_1 : forall f s, avl s -> avl (partition f s)#1. -Proof. - unfold partition; intros; apply partition_acc_avl_1; auto. -Qed. - -Lemma partition_avl_2 : forall f s, avl s -> avl (partition f s)#2. -Proof. - unfold partition; intros; apply partition_acc_avl_2; auto. -Qed. - -End AvlProofs. - - -Module OcamlOps (Import I:Int)(X:OrderedType). -Module Import AvlProofs := AvlProofs I X. -Import Raw. -Import Raw.Proofs. -Import II. -Open Local Scope pair_scope. -Open Local Scope nat_scope. - -(** Properties of cardinal *) - -Lemma bal_cardinal : forall l x r, - cardinal (bal l x r) = S (cardinal l + cardinal r). -Proof. - intros l x r; functional induction bal l x r; intros; clearf; - simpl; auto with arith; romega with *. -Qed. - -Lemma add_cardinal : forall x s, - cardinal (add x s) <= S (cardinal s). -Proof. - intros; functional induction add x s; simpl; auto with arith; - rewrite bal_cardinal; romega with *. -Qed. - -Lemma join_cardinal : forall l x r, - cardinal (join l x r) <= S (cardinal l + cardinal r). -Proof. - join_tac; auto with arith. - simpl; apply add_cardinal. - simpl; destruct X.compare; simpl; auto with arith. - generalize (bal_cardinal (add x ll) lx lr) (add_cardinal x ll); - romega with *. - generalize (bal_cardinal ll lx (add x lr)) (add_cardinal x lr); - romega with *. - generalize (bal_cardinal ll lx (join lr x (Node rl rx rr rh))) - (Hlr x (Node rl rx rr rh)); simpl; romega with *. - simpl S in *; generalize (bal_cardinal (join (Node ll lx lr lh) x rl) rx rr). - romega with *. -Qed. - -Lemma split_cardinal_1 : forall x s, - (cardinal (split x s)#l <= cardinal s)%nat. -Proof. - intros x s; functional induction split x s; simpl; auto. - rewrite e1 in IHt; simpl in *. - romega with *. - romega with *. - rewrite e1 in IHt; simpl in *. - generalize (@join_cardinal l y rl); romega with *. -Qed. - -Lemma split_cardinal_2 : forall x s, - (cardinal (split x s)#r <= cardinal s)%nat. -Proof. - intros x s; functional induction split x s; simpl; auto. - rewrite e1 in IHt; simpl in *. - generalize (@join_cardinal rl y r); romega with *. - romega with *. - rewrite e1 in IHt; simpl in *; romega with *. -Qed. - -(** * [ocaml_union], an union faithful to the original ocaml code *) - -Definition cardinal2 (s:t*t) := (cardinal s#1 + cardinal s#2)%nat. - -Ltac ocaml_union_tac := - intros; unfold cardinal2; simpl fst in *; simpl snd in *; - match goal with H: split ?x ?s = _ |- _ => - generalize (split_cardinal_1 x s) (split_cardinal_2 x s); - rewrite H; simpl; romega with * - end. - -Import Logic. (* Unhide eq, otherwise Function complains. *) - -Function ocaml_union (s : t * t) { measure cardinal2 s } : t := - match s with - | (Leaf, Leaf) => s#2 - | (Leaf, Node _ _ _ _) => s#2 - | (Node _ _ _ _, Leaf) => s#1 - | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) => - if ge_lt_dec h1 h2 then - if eq_dec h2 1%I then add x2 s#1 else - let (l2',_,r2') := split x1 s#2 in - join (ocaml_union (l1,l2')) x1 (ocaml_union (r1,r2')) - else - if eq_dec h1 1%I then add x1 s#2 else - let (l1',_,r1') := split x2 s#1 in - join (ocaml_union (l1',l2)) x2 (ocaml_union (r1',r2)) - end. -Proof. -abstract ocaml_union_tac. -abstract ocaml_union_tac. -abstract ocaml_union_tac. -abstract ocaml_union_tac. -Defined. - -Lemma ocaml_union_in : forall s y, - bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> - (In y (ocaml_union s) <-> In y s#1 \/ In y s#2). -Proof. - intros s; functional induction ocaml_union s; intros y B1 A1 B2 A2; - simpl fst in *; simpl snd in *; try clear e0 e1. - intuition_in. - intuition_in. - intuition_in. - (* add x2 s#1 *) - inv avl. - rewrite (height_0 H); [ | avl_nn l2; omega_max]. - rewrite (height_0 H0); [ | avl_nn r2; omega_max]. - rewrite add_in; intuition_in. - (* join (union (l1,l2')) x1 (union (r1,r2')) *) - generalize - (split_avl x1 A2) (split_bst x1 B2) - (split_in_1 x1 y B2) (split_in_2 x1 y B2). - rewrite e2; simpl. - destruct 1; destruct 1; inv avl; inv bst. - rewrite join_in, IHt, IHt0; auto. - do 2 (intro Eq; rewrite Eq; clear Eq). - case (X.compare y x1); intuition_in. - (* add x1 s#2 *) - inv avl. - rewrite (height_0 H3); [ | avl_nn l1; omega_max]. - rewrite (height_0 H4); [ | avl_nn r1; omega_max]. - rewrite add_in; auto; intuition_in. - (* join (union (l1',l2)) x1 (union (r1',r2)) *) - generalize - (split_avl x2 A1) (split_bst x2 B1) - (split_in_1 x2 y B1) (split_in_2 x2 y B1). - rewrite e2; simpl. - destruct 1; destruct 1; inv avl; inv bst. - rewrite join_in, IHt, IHt0; auto. - do 2 (intro Eq; rewrite Eq; clear Eq). - case (X.compare y x2); intuition_in. -Qed. - -Lemma ocaml_union_bst : forall s, - bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> bst (ocaml_union s). -Proof. - intros s; functional induction ocaml_union s; intros B1 A1 B2 A2; - simpl fst in *; simpl snd in *; try clear e0 e1; - try apply add_bst; auto. - (* join (union (l1,l2')) x1 (union (r1,r2')) *) - clear _x _x0; factornode l2 x2 r2 h2 as s2. - generalize (split_avl x1 A2) (split_bst x1 B2) - (@split_in_1 s2 x1)(@split_in_2 s2 x1). - rewrite e2; simpl. - destruct 1; destruct 1; intros. - inv bst; inv avl. - apply join_bst; auto. - intro y; rewrite ocaml_union_in, H3; intuition_in. - intro y; rewrite ocaml_union_in, H4; intuition_in. - (* join (union (l1',l2)) x1 (union (r1',r2)) *) - clear _x _x0; factornode l1 x1 r1 h1 as s1. - generalize (split_avl x2 A1) (split_bst x2 B1) - (@split_in_1 s1 x2)(@split_in_2 s1 x2). - rewrite e2; simpl. - destruct 1; destruct 1; intros. - inv bst; inv avl. - apply join_bst; auto. - intro y; rewrite ocaml_union_in, H3; intuition_in. - intro y; rewrite ocaml_union_in, H4; intuition_in. -Qed. - -Lemma ocaml_union_avl : forall s, - avl s#1 -> avl s#2 -> avl (ocaml_union s). -Proof. - intros s; functional induction ocaml_union s; - simpl fst in *; simpl snd in *; auto. - intros A1 A2; generalize (split_avl x1 A2); rewrite e2; simpl. - inv avl; destruct 1; auto. - intros A1 A2; generalize (split_avl x2 A1); rewrite e2; simpl. - inv avl; destruct 1; auto. -Qed. - -Lemma ocaml_union_alt : forall s, bst s#1 -> avl s#1 -> bst s#2 -> avl s#2 -> - Equal (ocaml_union s) (union s#1 s#2). -Proof. - red; intros; rewrite ocaml_union_in, union_in; simpl; intuition. -Qed. - - -(** * [ocaml_subset], a subset faithful to the original ocaml code *) - -Function ocaml_subset (s:t*t) { measure cardinal2 s } : bool := - match s with - | (Leaf, _) => true - | (Node _ _ _ _, Leaf) => false - | (Node l1 x1 r1 h1, Node l2 x2 r2 h2) => - match X.compare x1 x2 with - | EQ _ => ocaml_subset (l1,l2) && ocaml_subset (r1,r2) - | LT _ => ocaml_subset (Node l1 x1 Leaf 0%I, l2) && ocaml_subset (r1,s#2) - | GT _ => ocaml_subset (Node Leaf x1 r1 0%I, r2) && ocaml_subset (l1,s#2) - end - end. - -Proof. - intros; unfold cardinal2; simpl; abstract romega with *. - intros; unfold cardinal2; simpl; abstract romega with *. - intros; unfold cardinal2; simpl; abstract romega with *. - intros; unfold cardinal2; simpl; abstract romega with *. - intros; unfold cardinal2; simpl; abstract romega with *. - intros; unfold cardinal2; simpl; abstract romega with *. -Defined. - -Lemma ocaml_subset_12 : forall s, - bst s#1 -> bst s#2 -> - (ocaml_subset s = true <-> Subset s#1 s#2). -Proof. - intros s; functional induction ocaml_subset s; simpl; - intros B1 B2; try clear e0. - intuition. - red; auto; inversion 1. - split; intros; try discriminate. - assert (H': In _x0 Leaf) by auto; inversion H'. - (**) - simpl in *; inv bst. - rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0. - unfold Subset; intuition_in. - assert (X.eq a x2) by order; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - (**) - simpl in *; inv bst. - rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0. - unfold Subset; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - (**) - simpl in *; inv bst. - rewrite andb_true_iff, IHb, IHb0; auto; clear IHb IHb0. - unfold Subset; intuition_in. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. - assert (In a (Node l2 x2 r2 h2)) by auto; intuition_in; order. -Qed. - -Lemma ocaml_subset_alt : forall s, bst s#1 -> bst s#2 -> - ocaml_subset s = subset s#1 s#2. -Proof. - intros. - generalize (ocaml_subset_12 H H0); rewrite <-subset_12 by auto. - destruct ocaml_subset; destruct subset; intuition. -Qed. - - - -(** [ocaml_compare], a compare faithful to the original ocaml code *) - -(** termination of [compare_aux] *) - -Fixpoint cardinal_e e := match e with - | End => 0 - | More _ s r => S (cardinal s + cardinal_e r) - end. - -Lemma cons_cardinal_e : forall s e, - cardinal_e (cons s e) = cardinal s + cardinal_e e. -Proof. - induction s; simpl; intros; auto. - rewrite IHs1; simpl; rewrite <- plus_n_Sm; auto with arith. -Qed. - -Definition cardinal_e_2 e := cardinal_e e#1 + cardinal_e e#2. - -Function ocaml_compare_aux - (e:enumeration*enumeration) { measure cardinal_e_2 e } : comparison := - match e with - | (End,End) => Eq - | (End,More _ _ _) => Lt - | (More _ _ _, End) => Gt - | (More x1 r1 e1, More x2 r2 e2) => - match X.compare x1 x2 with - | EQ _ => ocaml_compare_aux (cons r1 e1, cons r2 e2) - | LT _ => Lt - | GT _ => Gt - end - end. - -Proof. -intros; unfold cardinal_e_2; simpl; -abstract (do 2 rewrite cons_cardinal_e; romega with *). -Defined. - -Definition ocaml_compare s1 s2 := - ocaml_compare_aux (cons s1 End, cons s2 End). - -Lemma ocaml_compare_aux_Cmp : forall e, - Cmp (ocaml_compare_aux e) (flatten_e e#1) (flatten_e e#2). -Proof. - intros e; functional induction ocaml_compare_aux e; simpl; intros; - auto; try discriminate. - apply L.eq_refl. - simpl in *. - apply cons_Cmp; auto. - rewrite <- 2 cons_1; auto. -Qed. - -Lemma ocaml_compare_Cmp : forall s1 s2, - Cmp (ocaml_compare s1 s2) (elements s1) (elements s2). -Proof. - unfold ocaml_compare; intros. - assert (H1:=cons_1 s1 End). - assert (H2:=cons_1 s2 End). - simpl in *; rewrite <- app_nil_end in *; rewrite <-H1,<-H2. - apply (@ocaml_compare_aux_Cmp (cons s1 End, cons s2 End)). -Qed. - -Lemma ocaml_compare_alt : forall s1 s2, bst s1 -> bst s2 -> - ocaml_compare s1 s2 = compare s1 s2. -Proof. - intros s1 s2 B1 B2. - generalize (ocaml_compare_Cmp s1 s2)(compare_Cmp s1 s2). - unfold Cmp. - destruct ocaml_compare; destruct compare; auto; intros; elimtype False. - elim (lt_not_eq B1 B2 H0); auto. - elim (lt_not_eq B2 B1 H0); auto. - apply eq_sym; auto. - elim (lt_not_eq B1 B2 H); auto. - elim (lt_not_eq B1 B1). - red; eapply L.lt_trans; eauto. - apply eq_refl. - elim (lt_not_eq B2 B1 H); auto. - apply eq_sym; auto. - elim (lt_not_eq B1 B2 H0); auto. - elim (lt_not_eq B1 B1). - red; eapply L.lt_trans; eauto. - apply eq_refl. -Qed. - - -(** * Equality test *) - -Definition ocaml_equal s1 s2 : bool := - match ocaml_compare s1 s2 with - | Eq => true - | _ => false - end. - -Lemma ocaml_equal_1 : forall s1 s2, bst s1 -> bst s2 -> - Equal s1 s2 -> ocaml_equal s1 s2 = true. -Proof. -unfold ocaml_equal; intros s1 s2 B1 B2 E. -generalize (ocaml_compare_Cmp s1 s2). -destruct (ocaml_compare s1 s2); auto; intros. -elim (lt_not_eq B1 B2 H E); auto. -elim (lt_not_eq B2 B1 H (eq_sym E)); auto. -Qed. - -Lemma ocaml_equal_2 : forall s1 s2, - ocaml_equal s1 s2 = true -> Equal s1 s2. -Proof. -unfold ocaml_equal; intros s1 s2 E. -generalize (ocaml_compare_Cmp s1 s2); - destruct ocaml_compare; auto; discriminate. -Qed. - -Lemma ocaml_equal_alt : forall s1 s2, bst s1 -> bst s2 -> - ocaml_equal s1 s2 = equal s1 s2. -Proof. -intros; unfold ocaml_equal, equal; rewrite ocaml_compare_alt; auto. -Qed. - -End OcamlOps. - - - -(** * Encapsulation - - We can implement [S] with balanced binary search trees. - When compared to [FSetAVL], we maintain here two invariants - (bst and avl) instead of only bst, which is enough for fulfilling - the FSet interface. - - This encapsulation propose the non-structural variants - [ocaml_union], [ocaml_subset], [ocaml_compare], [ocaml_equal]. -*) - -Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. - - Module E := X. - Module Import OcamlOps := OcamlOps I X. - Import AvlProofs. - Import Raw. - Import Raw.Proofs. - - Record bbst := Bbst {this :> Raw.t; is_bst : bst this; is_avl : avl this}. - Definition t := bbst. - Definition elt := E.t. - - Definition In (x : elt) (s : t) : Prop := In x s. - Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'. - Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'. - Definition Empty (s:t) : Prop := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) (s:t) : Prop := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) (s:t) : Prop := exists x, In x s /\ P x. - - Lemma In_1 : forall (s:t)(x y:elt), E.eq x y -> In x s -> In y s. - Proof. intro s; exact (@In_1 s). Qed. - - Definition mem (x:elt)(s:t) : bool := mem x s. - - Definition empty : t := Bbst empty_bst empty_avl. - Definition is_empty (s:t) : bool := is_empty s. - Definition singleton (x:elt) : t := - Bbst (singleton_bst x) (singleton_avl x). - Definition add (x:elt)(s:t) : t := - Bbst (add_bst x (is_bst s)) (add_avl x (is_avl s)). - Definition remove (x:elt)(s:t) : t := - Bbst (remove_bst x (is_bst s)) (remove_avl x (is_avl s)). - Definition inter (s s':t) : t := - Bbst (inter_bst (is_bst s) (is_bst s')) - (inter_avl (is_avl s) (is_avl s')). - Definition union (s s':t) : t := - Bbst (union_bst (is_bst s) (is_bst s')) - (union_avl (is_avl s) (is_avl s')). - Definition ocaml_union (s s':t) : t := - Bbst (@ocaml_union_bst (s.(this),s'.(this)) - (is_bst s) (is_avl s) (is_bst s') (is_avl s')) - (@ocaml_union_avl (s.(this),s'.(this)) (is_avl s) (is_avl s')). - Definition diff (s s':t) : t := - Bbst (diff_bst (is_bst s) (is_bst s')) - (diff_avl (is_avl s) (is_avl s')). - Definition elements (s:t) : list elt := elements s. - Definition min_elt (s:t) : option elt := min_elt s. - Definition max_elt (s:t) : option elt := max_elt s. - Definition choose (s:t) : option elt := choose s. - Definition fold (B : Type) (f : elt -> B -> B) (s:t) : B -> B := fold f s. - Definition cardinal (s:t) : nat := cardinal s. - Definition filter (f : elt -> bool) (s:t) : t := - Bbst (filter_bst f (is_bst s)) (filter_avl f (is_avl s)). - Definition for_all (f : elt -> bool) (s:t) : bool := for_all f s. - Definition exists_ (f : elt -> bool) (s:t) : bool := exists_ f s. - Definition partition (f : elt -> bool) (s:t) : t * t := - let p := partition f s in - (@Bbst (fst p) (partition_bst_1 f (is_bst s)) - (partition_avl_1 f (is_avl s)), - @Bbst (snd p) (partition_bst_2 f (is_bst s)) - (partition_avl_2 f (is_avl s))). - - Definition equal (s s':t) : bool := equal s s'. - Definition ocaml_equal (s s':t) : bool := ocaml_equal s s'. - Definition subset (s s':t) : bool := subset s s'. - Definition ocaml_subset (s s':t) : bool := - ocaml_subset (s.(this),s'.(this)). - - Definition eq (s s':t) : Prop := Equal s s'. - Definition lt (s s':t) : Prop := lt s s'. - - Definition compare (s s':t) : Compare lt eq s s'. - Proof. - intros (s,b,a) (s',b',a'). - generalize (compare_Cmp s s'). - destruct Raw.compare; intros; [apply EQ|apply LT|apply GT]; red; auto. - change (Raw.Equal s s'); auto. - Defined. - - Definition ocaml_compare (s s':t) : Compare lt eq s s'. - Proof. - intros (s,b,a) (s',b',a'). - generalize (ocaml_compare_Cmp s s'). - destruct ocaml_compare; intros; [apply EQ|apply LT|apply GT]; red; auto. - change (Raw.Equal s s'); auto. - Defined. - - Definition eq_dec (s s':t) : { eq s s' } + { ~ eq s s' }. - Proof. - intros (s,b,a) (s',b',a'); unfold eq; simpl. - case_eq (Raw.equal s s'); intro H; [left|right]. - apply equal_2; auto. - intro H'; rewrite equal_1 in H; auto; discriminate. - Defined. - - (* specs *) - Section Specs. - Variable s s' s'': t. - Variable x y : elt. - - Hint Resolve is_bst is_avl. - - Lemma mem_1 : In x s -> mem x s = true. - Proof. exact (mem_1 (is_bst s)). Qed. - Lemma mem_2 : mem x s = true -> In x s. - Proof. exact (@mem_2 s x). Qed. - - Lemma equal_1 : Equal s s' -> equal s s' = true. - Proof. exact (equal_1 (is_bst s) (is_bst s')). Qed. - Lemma equal_2 : equal s s' = true -> Equal s s'. - Proof. exact (@equal_2 s s'). Qed. - - Lemma ocaml_equal_alt : ocaml_equal s s' = equal s s'. - Proof. - destruct s; destruct s'; unfold ocaml_equal, equal; simpl. - apply ocaml_equal_alt; auto. - Qed. - - Lemma ocaml_equal_1 : Equal s s' -> ocaml_equal s s' = true. - Proof. exact (ocaml_equal_1 (is_bst s) (is_bst s')). Qed. - Lemma ocaml_equal_2 : ocaml_equal s s' = true -> Equal s s'. - Proof. exact (@ocaml_equal_2 s s'). Qed. - - Ltac wrap t H := unfold t, In; simpl; rewrite H; auto; intuition. - - Lemma subset_1 : Subset s s' -> subset s s' = true. - Proof. wrap subset subset_12. Qed. - Lemma subset_2 : subset s s' = true -> Subset s s'. - Proof. wrap subset subset_12. Qed. - - Lemma ocaml_subset_alt : ocaml_subset s s' = subset s s'. - Proof. - destruct s; destruct s'; unfold ocaml_subset, subset; simpl. - rewrite ocaml_subset_alt; auto. - Qed. - - Lemma ocaml_subset_1 : Subset s s' -> ocaml_subset s s' = true. - Proof. wrap ocaml_subset ocaml_subset_12; simpl; auto. Qed. - Lemma ocaml_subset_2 : ocaml_subset s s' = true -> Subset s s'. - Proof. wrap ocaml_subset ocaml_subset_12; simpl; auto. Qed. - - Lemma empty_1 : Empty empty. - Proof. exact empty_1. Qed. - - Lemma is_empty_1 : Empty s -> is_empty s = true. - Proof. exact (@is_empty_1 s). Qed. - Lemma is_empty_2 : is_empty s = true -> Empty s. - Proof. exact (@is_empty_2 s). Qed. - - Lemma add_1 : E.eq x y -> In y (add x s). - Proof. wrap add add_in. Qed. - Lemma add_2 : In y s -> In y (add x s). - Proof. wrap add add_in. Qed. - Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. - Proof. wrap add add_in. elim H; auto. Qed. - - Lemma remove_1 : E.eq x y -> ~ In y (remove x s). - Proof. wrap remove remove_in. Qed. - Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). - Proof. wrap remove remove_in. Qed. - Lemma remove_3 : In y (remove x s) -> In y s. - Proof. wrap remove remove_in. Qed. - - Lemma singleton_1 : In y (singleton x) -> E.eq x y. - Proof. exact (@singleton_1 x y). Qed. - Lemma singleton_2 : E.eq x y -> In y (singleton x). - Proof. exact (@singleton_2 x y). Qed. - - Lemma union_1 : In x (union s s') -> In x s \/ In x s'. - Proof. wrap union union_in. Qed. - Lemma union_2 : In x s -> In x (union s s'). - Proof. wrap union union_in. Qed. - Lemma union_3 : In x s' -> In x (union s s'). - Proof. wrap union union_in. Qed. - - Lemma ocaml_union_alt : Equal (ocaml_union s s') (union s s'). - Proof. - unfold ocaml_union, union, Equal, In. - destruct s as (s0,b,a); destruct s' as (s0',b',a'); simpl. - exact (@ocaml_union_alt (s0,s0') b a b' a'). - Qed. - - Lemma ocaml_union_1 : In x (ocaml_union s s') -> In x s \/ In x s'. - Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed. - Lemma ocaml_union_2 : In x s -> In x (ocaml_union s s'). - Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed. - Lemma ocaml_union_3 : In x s' -> In x (ocaml_union s s'). - Proof. wrap ocaml_union ocaml_union_in; simpl; auto. Qed. - - Lemma inter_1 : In x (inter s s') -> In x s. - Proof. wrap inter inter_in. Qed. - Lemma inter_2 : In x (inter s s') -> In x s'. - Proof. wrap inter inter_in. Qed. - Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). - Proof. wrap inter inter_in. Qed. - - Lemma diff_1 : In x (diff s s') -> In x s. - Proof. wrap diff diff_in. Qed. - Lemma diff_2 : In x (diff s s') -> ~ In x s'. - Proof. wrap diff diff_in. Qed. - Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - Proof. wrap diff diff_in. Qed. - - Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. - unfold fold, elements; intros; apply fold_1; auto. - Qed. - - Lemma cardinal_1 : cardinal s = length (elements s). - Proof. - unfold cardinal, elements; intros; apply elements_cardinal; auto. - Qed. - - Section Filter. - Variable f : elt -> bool. - - Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Proof. intro. wrap filter filter_in. Qed. - Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Proof. intro. wrap filter filter_in. Qed. - Lemma filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. intro. wrap filter filter_in. Qed. - - Lemma for_all_1 : compat_bool E.eq f -> For_all (fun x => f x = true) s -> for_all f s = true. - Proof. exact (@for_all_1 f s). Qed. - Lemma for_all_2 : compat_bool E.eq f -> for_all f s = true -> For_all (fun x => f x = true) s. - Proof. exact (@for_all_2 f s). Qed. - - Lemma exists_1 : compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. exact (@exists_1 f s). Qed. - Lemma exists_2 : compat_bool E.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. exact (@exists_2 f s). Qed. - - Lemma partition_1 : compat_bool E.eq f -> - Equal (fst (partition f s)) (filter f s). - Proof. - unfold partition, filter, Equal, In; simpl ;intros H a. - rewrite partition_in_1, filter_in; intuition. - Qed. - - Lemma partition_2 : compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - unfold partition, filter, Equal, In; simpl ;intros H a. - rewrite partition_in_2, filter_in; intuition. - rewrite H2; auto. - destruct (f a); auto. - red; intros; f_equal. - rewrite (H _ _ H0); auto. - Qed. - - End Filter. - - Lemma elements_1 : In x s -> InA E.eq x (elements s). - Proof. wrap elements elements_in. Qed. - Lemma elements_2 : InA E.eq x (elements s) -> In x s. - Proof. wrap elements elements_in. Qed. - Lemma elements_3 : sort E.lt (elements s). - Proof. exact (elements_sort (is_bst s)). Qed. - Lemma elements_3w : NoDupA E.eq (elements s). - Proof. exact (elements_nodup (is_bst s)). Qed. - - Lemma min_elt_1 : min_elt s = Some x -> In x s. - Proof. exact (@min_elt_1 s x). Qed. - Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. - Proof. exact (@min_elt_2 s x y (is_bst s)). Qed. - Lemma min_elt_3 : min_elt s = None -> Empty s. - Proof. exact (@min_elt_3 s). Qed. - - Lemma max_elt_1 : max_elt s = Some x -> In x s. - Proof. exact (@max_elt_1 s x). Qed. - Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. - Proof. exact (@max_elt_2 s x y (is_bst s)). Qed. - Lemma max_elt_3 : max_elt s = None -> Empty s. - Proof. exact (@max_elt_3 s). Qed. - - Lemma choose_1 : choose s = Some x -> In x s. - Proof. exact (@choose_1 s x). Qed. - Lemma choose_2 : choose s = None -> Empty s. - Proof. exact (@choose_2 s). Qed. - Lemma choose_3 : choose s = Some x -> choose s' = Some y -> - Equal s s' -> E.eq x y. - Proof. exact (@choose_3 _ _ (is_bst s) (is_bst s') x y). Qed. - - Lemma eq_refl : eq s s. - Proof. exact (eq_refl s). Qed. - Lemma eq_sym : eq s s' -> eq s' s. - Proof. exact (@eq_sym s s'). Qed. - Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''. - Proof. exact (@eq_trans s s' s''). Qed. - - Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''. - Proof. exact (@lt_trans s s' s''). Qed. - Lemma lt_not_eq : lt s s' -> ~eq s s'. - Proof. exact (@lt_not_eq _ _ (is_bst s) (is_bst s')). Qed. - - End Specs. -End IntMake. - -(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) - -Module Make (X: OrderedType) <: S with Module E := X - :=IntMake(Z_as_Int)(X). - diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index 79eea34e..8aede552 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -6,17 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetInterface.v 11701 2008-12-18 11:49:12Z letouzey $ *) +(* $Id$ *) (** * Finite set library *) -(** Set interfaces, inspired by the one of Ocaml. When compared with - Ocaml, the main differences are: +(** Set interfaces, inspired by the one of Ocaml. When compared with + Ocaml, the main differences are: - the lack of [iter] function, useless since Coq is purely functional - the use of [option] types instead of [Not_found] exceptions - - the use of [nat] instead of [int] for the [cardinal] function + - the use of [nat] instead of [int] for the [cardinal] function - Several variants of the set interfaces are available: + Several variants of the set interfaces are available: - [WSfun] : functorial signature for weak sets, non-dependent style - [WS] : self-contained version of [WSfun] - [Sfun] : functorial signature for ordered sets, non-dependent style @@ -24,7 +24,7 @@ - [Sdep] : analog of [S] written using dependent style If unsure, [S] is probably what you're looking for: other signatures - are subsets of it, apart from [Sdep] which is isomorphic to [S] (see + are subsets of it, apart from [Sdep] which is isomorphic to [S] (see [FSetBridge]). *) @@ -34,14 +34,14 @@ Unset Strict Implicit. (** * Non-dependent signatures - The following signatures presents sets as purely informative + The following signatures presents sets as purely informative programs together with axioms *) (** ** Functorial signature for weak sets - Weak sets are sets without ordering on base elements, only + Weak sets are sets without ordering on base elements, only a decidable equality. *) Module Type WSfun (E : DecidableType). @@ -57,7 +57,7 @@ Module Type WSfun (E : DecidableType). Definition Empty s := forall a : elt, ~ In a s. Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). @@ -137,7 +137,7 @@ Module Type WSfun (E : DecidableType). the set is empty. Which element is chosen is unspecified. Equal sets could return different elements. *) - Section Spec. + Section Spec. Variable s s' s'': t. Variable x y : elt. @@ -146,15 +146,15 @@ Module Type WSfun (E : DecidableType). Parameter In_1 : E.eq x y -> In x s -> In y s. (** Specification of [eq] *) - Parameter eq_refl : eq s s. + Parameter eq_refl : eq s s. Parameter eq_sym : eq s s' -> eq s' s. Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''. (** Specification of [mem] *) Parameter mem_1 : In x s -> mem x s = true. - Parameter mem_2 : mem x s = true -> In x s. - - (** Specification of [equal] *) + Parameter mem_2 : mem x s = true -> In x s. + + (** Specification of [equal] *) Parameter equal_1 : Equal s s' -> equal s s' = true. Parameter equal_2 : equal s s' = true -> Equal s s'. @@ -166,13 +166,13 @@ Module Type WSfun (E : DecidableType). Parameter empty_1 : Empty empty. (** Specification of [is_empty] *) - Parameter is_empty_1 : Empty s -> is_empty s = true. + Parameter is_empty_1 : Empty s -> is_empty s = true. Parameter is_empty_2 : is_empty s = true -> Empty s. - + (** Specification of [add] *) Parameter add_1 : E.eq x y -> In y (add x s). Parameter add_2 : In y s -> In y (add x s). - Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. + Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. (** Specification of [remove] *) Parameter remove_1 : E.eq x y -> ~ In y (remove x s). @@ -180,12 +180,12 @@ Module Type WSfun (E : DecidableType). Parameter remove_3 : In y (remove x s) -> In y s. (** Specification of [singleton] *) - Parameter singleton_1 : In y (singleton x) -> E.eq x y. - Parameter singleton_2 : E.eq x y -> In y (singleton x). + Parameter singleton_1 : In y (singleton x) -> E.eq x y. + Parameter singleton_2 : E.eq x y -> In y (singleton x). (** Specification of [union] *) Parameter union_1 : In x (union s s') -> In x s \/ In x s'. - Parameter union_2 : In x s -> In x (union s s'). + Parameter union_2 : In x s -> In x (union s s'). Parameter union_3 : In x s' -> In x (union s s'). (** Specification of [inter] *) @@ -194,24 +194,24 @@ Module Type WSfun (E : DecidableType). Parameter inter_3 : In x s -> In x s' -> In x (inter s s'). (** Specification of [diff] *) - Parameter diff_1 : In x (diff s s') -> In x s. + Parameter diff_1 : In x (diff s s') -> In x s. Parameter diff_2 : In x (diff s s') -> ~ In x s'. Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - - (** Specification of [fold] *) + + (** Specification of [fold] *) Parameter fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), fold f s i = fold_left (fun a e => f e a) (elements s) i. - (** Specification of [cardinal] *) + (** Specification of [cardinal] *) Parameter cardinal_1 : cardinal s = length (elements s). Section Filter. - + Variable f : elt -> bool. (** Specification of [filter] *) - Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. + Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. Parameter filter_3 : compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). @@ -243,7 +243,7 @@ Module Type WSfun (E : DecidableType). (** Specification of [elements] *) Parameter elements_1 : In x s -> InA E.eq x (elements s). Parameter elements_2 : InA E.eq x (elements s) -> In x s. - (** When compared with ordered sets, here comes the only + (** When compared with ordered sets, here comes the only property that is really weaker: *) Parameter elements_3w : NoDupA E.eq (elements s). @@ -257,11 +257,11 @@ Module Type WSfun (E : DecidableType). is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 remove_2 singleton_2 union_1 union_2 union_3 inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 - partition_1 partition_2 elements_1 elements_3w + partition_1 partition_2 elements_1 elements_3w : set. Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 - filter_1 filter_2 for_all_2 exists_2 elements_2 + filter_1 filter_2 for_all_2 exists_2 elements_2 : set. End WSfun. @@ -270,12 +270,12 @@ End WSfun. (** ** Static signature for weak sets - Similar to the functorial signature [SW], except that the + Similar to the functorial signature [SW], except that the module [E] of base elements is incorporated in the signature. *) Module Type WS. Declare Module E : DecidableType. - Include Type WSfun E. + Include WSfun E. End WS. @@ -286,7 +286,7 @@ End WS. and some stronger specifications for other functions. *) Module Type Sfun (E : OrderedType). - Include Type WSfun E. + Include WSfun E. Parameter lt : t -> t -> Prop. Parameter compare : forall s s' : t, Compare lt eq s s'. @@ -295,48 +295,48 @@ Module Type Sfun (E : OrderedType). Parameter min_elt : t -> option elt. (** Return the smallest element of the given set - (with respect to the [E.compare] ordering), + (with respect to the [E.compare] ordering), or [None] if the set is empty. *) Parameter max_elt : t -> option elt. (** Same as [min_elt], but returns the largest element of the given set. *) - Section Spec. + Section Spec. Variable s s' s'' : t. Variable x y : elt. - + (** Specification of [lt] *) Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''. Parameter lt_not_eq : lt s s' -> ~ eq s s'. (** Additional specification of [elements] *) - Parameter elements_3 : sort E.lt (elements s). + Parameter elements_3 : sort E.lt (elements s). (** Remark: since [fold] is specified via [elements], this stronger - specification of [elements] has an indirect impact on [fold], + specification of [elements] has an indirect impact on [fold], which can now be proved to receive elements in increasing order. *) (** Specification of [min_elt] *) - Parameter min_elt_1 : min_elt s = Some x -> In x s. - Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. + Parameter min_elt_1 : min_elt s = Some x -> In x s. + Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. Parameter min_elt_3 : min_elt s = None -> Empty s. - (** Specification of [max_elt] *) - Parameter max_elt_1 : max_elt s = Some x -> In x s. - Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. + (** Specification of [max_elt] *) + Parameter max_elt_1 : max_elt s = Some x -> In x s. + Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. Parameter max_elt_3 : max_elt s = None -> Empty s. (** Additional specification of [choose] *) - Parameter choose_3 : choose s = Some x -> choose s' = Some y -> + Parameter choose_3 : choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. End Spec. Hint Resolve elements_3 : set. - Hint Immediate + Hint Immediate min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3 : set. End Sfun. @@ -344,12 +344,12 @@ End Sfun. (** ** Static signature for sets on ordered elements - Similar to the functorial signature [Sfun], except that the + Similar to the functorial signature [Sfun], except that the module [E] of base elements is incorporated in the signature. *) Module Type S. Declare Module E : OrderedType. - Include Type Sfun E. + Include Sfun E. End S. @@ -411,7 +411,7 @@ Module Type Sdep. Parameter singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. - + Parameter remove : forall (x : elt) (s : t), @@ -433,7 +433,7 @@ Module Type Sdep. {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. Parameter equal : forall s s' : t, {s[=]s'} + {~ s[=]s'}. - + Parameter subset : forall s s' : t, {Subset s s'} + {~ Subset s s'}. Parameter @@ -447,7 +447,7 @@ Module Type Sdep. forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. - + Parameter exists_ : forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) @@ -474,7 +474,7 @@ Module Type Sdep. Parameter fold : forall (A : Type) (f : elt -> A -> A) (s : t) (i : A), - {r : A | let (l,_) := elements s in + {r : A | let (l,_) := elements s in r = fold_left (fun a e => f e a) l i}. Parameter @@ -494,10 +494,10 @@ Module Type Sdep. Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}. - (** The [choose_3] specification of [S] cannot be packed + (** The [choose_3] specification of [S] cannot be packed in the dependent version of [choose], so we leave it separate. *) - Parameter choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with + Parameter choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with | inleft (exist x _), inleft (exist x' _) => E.eq x x' | inright _, inright _ => True | _, _ => False diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v index b009e109..f83259c4 100644 --- a/theories/FSets/FSetList.v +++ b/theories/FSets/FSetList.v @@ -6,1271 +6,24 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetList.v 11866 2009-01-28 19:10:15Z letouzey $ *) +(* $Id$ *) (** * Finite sets library *) -(** This file proposes an implementation of the non-dependant +(** This file proposes an implementation of the non-dependant interface [FSetInterface.S] using strictly ordered list. *) Require Export FSetInterface. Set Implicit Arguments. Unset Strict Implicit. -(** * Functions over lists +(** This is just a compatibility layer, the real implementation + is now in [MSetList] *) - First, we provide sets as lists which are not necessarily sorted. - The specs are proved under the additional condition of being sorted. - And the functions returning sets are proved to preserve this invariant. *) - -Module Raw (X: OrderedType). - - Module MX := OrderedTypeFacts X. - Import MX. - - Definition elt := X.t. - Definition t := list elt. - - Definition empty : t := nil. - - Definition is_empty (l : t) : bool := if l then true else false. - - (** ** The set operations. *) - - Fixpoint mem (x : elt) (s : t) {struct s} : bool := - match s with - | nil => false - | y :: l => - match X.compare x y with - | LT _ => false - | EQ _ => true - | GT _ => mem x l - end - end. - - Fixpoint add (x : elt) (s : t) {struct s} : t := - match s with - | nil => x :: nil - | y :: l => - match X.compare x y with - | LT _ => x :: s - | EQ _ => s - | GT _ => y :: add x l - end - end. - - Definition singleton (x : elt) : t := x :: nil. - - Fixpoint remove (x : elt) (s : t) {struct s} : t := - match s with - | nil => nil - | y :: l => - match X.compare x y with - | LT _ => s - | EQ _ => l - | GT _ => y :: remove x l - end - end. - - Fixpoint union (s : t) : t -> t := - match s with - | nil => fun s' => s' - | x :: l => - (fix union_aux (s' : t) : t := - match s' with - | nil => s - | x' :: l' => - match X.compare x x' with - | LT _ => x :: union l s' - | EQ _ => x :: union l l' - | GT _ => x' :: union_aux l' - end - end) - end. - - Fixpoint inter (s : t) : t -> t := - match s with - | nil => fun _ => nil - | x :: l => - (fix inter_aux (s' : t) : t := - match s' with - | nil => nil - | x' :: l' => - match X.compare x x' with - | LT _ => inter l s' - | EQ _ => x :: inter l l' - | GT _ => inter_aux l' - end - end) - end. - - Fixpoint diff (s : t) : t -> t := - match s with - | nil => fun _ => nil - | x :: l => - (fix diff_aux (s' : t) : t := - match s' with - | nil => s - | x' :: l' => - match X.compare x x' with - | LT _ => x :: diff l s' - | EQ _ => diff l l' - | GT _ => diff_aux l' - end - end) - end. - - Fixpoint equal (s : t) : t -> bool := - fun s' : t => - match s, s' with - | nil, nil => true - | x :: l, x' :: l' => - match X.compare x x' with - | EQ _ => equal l l' - | _ => false - end - | _, _ => false - end. - - Fixpoint subset (s s' : t) {struct s'} : bool := - match s, s' with - | nil, _ => true - | x :: l, x' :: l' => - match X.compare x x' with - | LT _ => false - | EQ _ => subset l l' - | GT _ => subset s l' - end - | _, _ => false - end. - - Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : - B -> B := fun i => match s with - | nil => i - | x :: l => fold f l (f x i) - end. - - Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t := - match s with - | nil => nil - | x :: l => if f x then x :: filter f l else filter f l - end. - - Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool := - match s with - | nil => true - | x :: l => if f x then for_all f l else false - end. - - Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool := - match s with - | nil => false - | x :: l => if f x then true else exists_ f l - end. - - Fixpoint partition (f : elt -> bool) (s : t) {struct s} : - t * t := - match s with - | nil => (nil, nil) - | x :: l => - let (s1, s2) := partition f l in - if f x then (x :: s1, s2) else (s1, x :: s2) - end. - - Definition cardinal (s : t) : nat := length s. - - Definition elements (x : t) : list elt := x. - - Definition min_elt (s : t) : option elt := - match s with - | nil => None - | x :: _ => Some x - end. - - Fixpoint max_elt (s : t) : option elt := - match s with - | nil => None - | x :: nil => Some x - | _ :: l => max_elt l - end. - - Definition choose := min_elt. - - (** ** Proofs of set operation specifications. *) - - Section ForNotations. - - Notation Sort := (sort X.lt). - Notation Inf := (lelistA X.lt). - Notation In := (InA X.eq). - - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) (s : t) := exists x, In x s /\ P x. - - Lemma mem_1 : - forall (s : t) (Hs : Sort s) (x : elt), In x s -> mem x s = true. - Proof. - simple induction s; intros. - inversion H. - inversion_clear Hs. - inversion_clear H0. - simpl; elim_comp; trivial. - simpl; elim_comp_gt x a; auto. - apply Sort_Inf_In with l; trivial. - Qed. - - Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. - Proof. - simple induction s. - intros; inversion H. - intros a l Hrec x. - simpl. - case (X.compare x a); intros; try discriminate; auto. - Qed. - - Lemma add_Inf : - forall (s : t) (x a : elt), Inf a s -> X.lt a x -> Inf a (add x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); intuition; inversion H0; - intuition. - Qed. - Hint Resolve add_Inf. - - Lemma add_sort : forall (s : t) (Hs : Sort s) (x : elt), Sort (add x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; - auto. - Qed. - - Lemma add_1 : - forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> In y (add x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); inversion_clear Hs; auto. - constructor; apply X.eq_trans with x; auto. - Qed. - - Lemma add_2 : - forall (s : t) (Hs : Sort s) (x y : elt), In y s -> In y (add x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); intuition. - inversion_clear Hs; inversion_clear H0; auto. - Qed. - - Lemma add_3 : - forall (s : t) (Hs : Sort s) (x y : elt), - ~ X.eq x y -> In y (add x s) -> In y s. - Proof. - simple induction s. - simpl; inversion_clear 3; auto; order. - simpl; intros a l Hrec Hs x y; case (X.compare x a); intros; - inversion_clear H0; inversion_clear Hs; auto. - order. - constructor 2; apply Hrec with x; auto. - Qed. - - Lemma remove_Inf : - forall (s : t) (Hs : Sort s) (x a : elt), Inf a s -> Inf a (remove x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); intuition; inversion_clear H0; auto. - inversion_clear Hs; apply Inf_lt with a; auto. - Qed. - Hint Resolve remove_Inf. - - Lemma remove_sort : - forall (s : t) (Hs : Sort s) (x : elt), Sort (remove x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; auto. - Qed. - - Lemma remove_1 : - forall (s : t) (Hs : Sort s) (x y : elt), X.eq x y -> ~ In y (remove x s). - Proof. - simple induction s. - simpl; red; intros; inversion H0. - simpl; intros; case (X.compare x a); intuition; inversion_clear Hs. - inversion_clear H1. - order. - generalize (Sort_Inf_In H2 H3 H4); order. - generalize (Sort_Inf_In H2 H3 H1); order. - inversion_clear H1. - order. - apply (H H2 _ _ H0 H4). - Qed. - - Lemma remove_2 : - forall (s : t) (Hs : Sort s) (x y : elt), - ~ X.eq x y -> In y s -> In y (remove x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.compare x a); intuition; inversion_clear Hs; - inversion_clear H1; auto. - destruct H0; apply X.eq_trans with a; auto. - Qed. - - Lemma remove_3 : - forall (s : t) (Hs : Sort s) (x y : elt), In y (remove x s) -> In y s. - Proof. - simple induction s. - simpl; intuition. - simpl; intros a l Hrec Hs x y; case (X.compare x a); intuition. - inversion_clear Hs; inversion_clear H; auto. - constructor 2; apply Hrec with x; auto. - Qed. - - Lemma singleton_sort : forall x : elt, Sort (singleton x). - Proof. - unfold singleton; simpl; auto. - Qed. - - Lemma singleton_1 : forall x y : elt, In y (singleton x) -> X.eq x y. - Proof. - unfold singleton; simpl; intuition. - inversion_clear H; auto; inversion H0. - Qed. - - Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x). - Proof. - unfold singleton; simpl; auto. - Qed. - - Ltac DoubleInd := - simple induction s; - [ simpl; auto; try solve [ intros; inversion H ] - | intros x l Hrec; simple induction s'; - [ simpl; auto; try solve [ intros; inversion H ] - | intros x' l' Hrec' Hs Hs'; inversion Hs; inversion Hs'; subst; - simpl ] ]. - - Lemma union_Inf : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt), - Inf a s -> Inf a s' -> Inf a (union s s'). - Proof. - DoubleInd. - intros i His His'; inversion_clear His; inversion_clear His'. - case (X.compare x x'); auto. - Qed. - Hint Resolve union_Inf. - - Lemma union_sort : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (union s s'). - Proof. - DoubleInd; case (X.compare x x'); intuition; constructor; auto. - apply Inf_eq with x'; trivial; apply union_Inf; trivial; apply Inf_eq with x; auto. - change (Inf x' (union (x :: l) l')); auto. - Qed. - - Lemma union_1 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x (union s s') -> In x s \/ In x s'. - Proof. - DoubleInd; case (X.compare x x'); intuition; inversion_clear H; intuition. - elim (Hrec (x' :: l') H1 Hs' x0); intuition. - elim (Hrec l' H1 H5 x0); intuition. - elim (H0 x0); intuition. - Qed. - - Lemma union_2 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x s -> In x (union s s'). - Proof. - DoubleInd. - intros i Hi; case (X.compare x x'); intuition; inversion_clear Hi; auto. - Qed. - - Lemma union_3 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x s' -> In x (union s s'). - Proof. - DoubleInd. - intros i Hi; case (X.compare x x'); inversion_clear Hi; intuition. - constructor; apply X.eq_trans with x'; auto. - Qed. - - Lemma inter_Inf : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt), - Inf a s -> Inf a s' -> Inf a (inter s s'). - Proof. - DoubleInd. - intros i His His'; inversion His; inversion His'; subst. - case (X.compare x x'); intuition. - apply Inf_lt with x; auto. - apply H3; auto. - apply Inf_lt with x'; auto. - Qed. - Hint Resolve inter_Inf. - - Lemma inter_sort : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (inter s s'). - Proof. - DoubleInd; case (X.compare x x'); auto. - constructor; auto. - apply Inf_eq with x'; trivial; apply inter_Inf; trivial; apply Inf_eq with x; auto. - Qed. - - Lemma inter_1 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x (inter s s') -> In x s. - Proof. - DoubleInd; case (X.compare x x'); intuition. - constructor 2; apply Hrec with (x'::l'); auto. - inversion_clear H; auto. - constructor 2; apply Hrec with l'; auto. - Qed. - - Lemma inter_2 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x (inter s s') -> In x s'. - Proof. - DoubleInd; case (X.compare x x'); intuition; inversion_clear H. - constructor 1; apply X.eq_trans with x; auto. - constructor 2; auto. - Qed. - - Lemma inter_3 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x s -> In x s' -> In x (inter s s'). - Proof. - DoubleInd. - intros i His His'; elim (X.compare x x'); intuition. - - inversion_clear His; auto. - generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) His'); order. - - inversion_clear His; auto; inversion_clear His'; auto. - constructor; apply X.eq_trans with x'; auto. - - change (In i (inter (x :: l) l')). - inversion_clear His'; auto. - generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) His); order. - Qed. - - Lemma diff_Inf : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (a : elt), - Inf a s -> Inf a s' -> Inf a (diff s s'). - Proof. - DoubleInd. - intros i His His'; inversion His; inversion His'. - case (X.compare x x'); intuition. - apply Hrec; trivial. - apply Inf_lt with x; auto. - apply Inf_lt with x'; auto. - apply H10; trivial. - apply Inf_lt with x'; auto. - Qed. - Hint Resolve diff_Inf. - - Lemma diff_sort : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Sort (diff s s'). - Proof. - DoubleInd; case (X.compare x x'); auto. - Qed. - - Lemma diff_1 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x (diff s s') -> In x s. - Proof. - DoubleInd; case (X.compare x x'); intuition. - inversion_clear H; auto. - constructor 2; apply Hrec with (x'::l'); auto. - constructor 2; apply Hrec with l'; auto. - Qed. - - Lemma diff_2 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x (diff s s') -> ~ In x s'. - Proof. - DoubleInd. - intros; intro Abs; inversion Abs. - case (X.compare x x'); intuition. - - inversion_clear H. - generalize (Sort_Inf_In Hs' (cons_leA _ _ _ _ l0) H3); order. - apply Hrec with (x'::l') x0; auto. - - inversion_clear H3. - generalize (Sort_Inf_In H1 H2 (diff_1 H1 H5 H)); order. - apply Hrec with l' x0; auto. - - inversion_clear H3. - generalize (Sort_Inf_In Hs (cons_leA _ _ _ _ l0) (diff_1 Hs H5 H)); order. - apply H0 with x0; auto. - Qed. - - Lemma diff_3 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s') (x : elt), - In x s -> ~ In x s' -> In x (diff s s'). - Proof. - DoubleInd. - intros i His His'; elim (X.compare x x'); intuition; inversion_clear His; auto. - elim His'; constructor; apply X.eq_trans with x; auto. - Qed. - - Lemma equal_1 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), - Equal s s' -> equal s s' = true. - Proof. - simple induction s; unfold Equal. - intro s'; case s'; auto. - simpl; intuition. - elim (H e); intros; assert (A : In e nil); auto; inversion A. - intros x l Hrec s'. - case s'. - intros; elim (H x); intros; assert (A : In x nil); auto; inversion A. - intros x' l' Hs Hs'; inversion Hs; inversion Hs'; subst. - simpl; case (X.compare x); intros; auto. - - elim (H x); intros. - assert (A : In x (x' :: l')); auto; inversion_clear A. - order. - generalize (Sort_Inf_In H5 H6 H4); order. - - apply Hrec; intuition; elim (H a); intros. - assert (A : In a (x' :: l')); auto; inversion_clear A; auto. - generalize (Sort_Inf_In H1 H2 H0); order. - assert (A : In a (x :: l)); auto; inversion_clear A; auto. - generalize (Sort_Inf_In H5 H6 H0); order. - - elim (H x'); intros. - assert (A : In x' (x :: l)); auto; inversion_clear A. - order. - generalize (Sort_Inf_In H1 H2 H4); order. - Qed. - - Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'. - Proof. - simple induction s; unfold Equal. - intro s'; case s'; intros. - intuition. - simpl in H; discriminate H. - intros x l Hrec s'. - case s'. - intros; simpl in H; discriminate. - intros x' l'; simpl; case (X.compare x); intros; auto; try discriminate. - elim (Hrec l' H a); intuition; inversion_clear H2; auto. - constructor; apply X.eq_trans with x; auto. - constructor; apply X.eq_trans with x'; auto. - Qed. - - Lemma subset_1 : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), - Subset s s' -> subset s s' = true. - Proof. - intros s s'; generalize s' s; clear s s'. - simple induction s'; unfold Subset. - intro s; case s; auto. - intros; elim (H e); intros; assert (A : In e nil); auto; inversion A. - intros x' l' Hrec s; case s. - simpl; auto. - intros x l Hs Hs'; inversion Hs; inversion Hs'; subst. - simpl; case (X.compare x); intros; auto. - - assert (A : In x (x' :: l')); auto; inversion_clear A. - order. - generalize (Sort_Inf_In H5 H6 H0); order. - - apply Hrec; intuition. - assert (A : In a (x' :: l')); auto; inversion_clear A; auto. - generalize (Sort_Inf_In H1 H2 H0); order. - - apply Hrec; intuition. - assert (A : In a (x' :: l')); auto; inversion_clear A; auto. - inversion_clear H0. - order. - generalize (Sort_Inf_In H1 H2 H4); order. - Qed. - - Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'. - Proof. - intros s s'; generalize s' s; clear s s'. - simple induction s'; unfold Subset. - intro s; case s; auto. - simpl; intros; discriminate H. - intros x' l' Hrec s; case s. - intros; inversion H0. - intros x l; simpl; case (X.compare x); intros; auto. - discriminate H. - inversion_clear H0. - constructor; apply X.eq_trans with x; auto. - constructor 2; apply Hrec with l; auto. - constructor 2; apply Hrec with (x::l); auto. - Qed. - - Lemma empty_sort : Sort empty. - Proof. - unfold empty; constructor. - Qed. - - Lemma empty_1 : Empty empty. - Proof. - unfold Empty, empty; intuition; inversion H. - Qed. - - Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true. - Proof. - unfold Empty; intro s; case s; simpl; intuition. - elim (H e); auto. - Qed. - - Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. - Proof. - unfold Empty; intro s; case s; simpl; intuition; - inversion H0. - Qed. - - Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s). - Proof. - unfold elements; auto. - Qed. - - Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s. - Proof. - unfold elements; auto. - Qed. - - Lemma elements_3 : forall (s : t) (Hs : Sort s), Sort (elements s). - Proof. - unfold elements; auto. - Qed. - - Lemma elements_3w : forall (s : t) (Hs : Sort s), NoDupA X.eq (elements s). - Proof. - unfold elements; auto. - Qed. - - Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. - Proof. - intro s; case s; simpl; intros; inversion H; auto. - Qed. - - Lemma min_elt_2 : - forall (s : t) (Hs : Sort s) (x y : elt), - min_elt s = Some x -> In y s -> ~ X.lt y x. - Proof. - simple induction s; simpl. - intros; inversion H. - intros a l; case l; intros; inversion H0; inversion_clear H1; subst. - order. - inversion H2. - order. - inversion_clear Hs. - inversion_clear H3. - generalize (H H1 e y (refl_equal (Some e)) H2); order. - Qed. - - Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s. - Proof. - unfold Empty; intro s; case s; simpl; intuition; - inversion H; inversion H0. - Qed. - - Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. - Proof. - simple induction s; simpl. - intros; inversion H. - intros x l; case l; simpl. - intuition. - inversion H0; auto. - intros. - constructor 2; apply (H _ H0). - Qed. - - Lemma max_elt_2 : - forall (s : t) (Hs : Sort s) (x y : elt), - max_elt s = Some x -> In y s -> ~ X.lt x y. - Proof. - simple induction s; simpl. - intros; inversion H. - intros x l; case l; simpl. - intuition. - inversion H0; subst. - inversion_clear H1. - order. - inversion H3. - intros; inversion_clear Hs; inversion_clear H3; inversion_clear H1. - assert (In e (e::l0)) by auto. - generalize (H H2 x0 e H0 H1); order. - generalize (H H2 x0 y H0 H3); order. - Qed. - - Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s. - Proof. - unfold Empty; simple induction s; simpl. - red; intros; inversion H0. - intros x l; case l; simpl; intros. - inversion H0. - elim (H H0 e); auto. - Qed. - - Definition choose_1 : - forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_1. - - Definition choose_2 : forall s : t, choose s = None -> Empty s := min_elt_3. - - Lemma choose_3: forall s s', Sort s -> Sort s' -> forall x x', - choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'. - Proof. - unfold choose, Equal; intros s s' Hs Hs' x x' Hx Hx' H. - assert (~X.lt x x'). - apply min_elt_2 with s'; auto. - rewrite <-H; auto using min_elt_1. - assert (~X.lt x' x). - apply min_elt_2 with s; auto. - rewrite H; auto using min_elt_1. - destruct (X.compare x x'); intuition. - Qed. - - Lemma fold_1 : - forall (s : t) (Hs : Sort s) (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. - induction s. - simpl; trivial. - intros. - inversion_clear Hs. - simpl; auto. - Qed. - - Lemma cardinal_1 : - forall (s : t) (Hs : Sort s), - cardinal s = length (elements s). - Proof. - auto. - Qed. - - Lemma filter_Inf : - forall (s : t) (Hs : Sort s) (x : elt) (f : elt -> bool), - Inf x s -> Inf x (filter f s). - Proof. - simple induction s; simpl. - intuition. - intros x l Hrec Hs a f Ha; inversion_clear Hs; inversion_clear Ha. - case (f x). - constructor; auto. - apply Hrec; auto. - apply Inf_lt with x; auto. - Qed. - - Lemma filter_sort : - forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (filter f s). - Proof. - simple induction s; simpl. - auto. - intros x l Hrec Hs f; inversion_clear Hs. - case (f x); auto. - constructor; auto. - apply filter_Inf; auto. - Qed. - - Lemma filter_1 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x (filter f s) -> In x s. - Proof. - simple induction s; simpl. - intros; inversion H0. - intros x l Hrec a f Hf. - case (f x); simpl. - inversion_clear 1. - constructor; auto. - constructor 2; apply (Hrec a f Hf); trivial. - constructor 2; apply (Hrec a f Hf); trivial. - Qed. - - Lemma filter_2 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x (filter f s) -> f x = true. - Proof. - simple induction s; simpl. - intros; inversion H0. - intros x l Hrec a f Hf. - generalize (Hf x); case (f x); simpl; auto. - inversion_clear 2; auto. - symmetry; auto. - Qed. - - Lemma filter_3 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. - simple induction s; simpl. - intros; inversion H0. - intros x l Hrec a f Hf. - generalize (Hf x); case (f x); simpl. - inversion_clear 2; auto. - inversion_clear 2; auto. - rewrite <- (H a (X.eq_sym H1)); intros; discriminate. - Qed. - - Lemma for_all_1 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Proof. - simple induction s; simpl; auto; unfold For_all. - intros x l Hrec f Hf. - generalize (Hf x); case (f x); simpl. - auto. - intros; rewrite (H x); auto. - Qed. - - Lemma for_all_2 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - Proof. - simple induction s; simpl; auto; unfold For_all. - intros; inversion H1. - intros x l Hrec f Hf. - intros A a; intros. - assert (f x = true). - generalize A; case (f x); auto. - rewrite H0 in A; simpl in A. - inversion_clear H; auto. - rewrite (Hf a x); auto. - Qed. - - Lemma exists_1 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. - simple induction s; simpl; auto; unfold Exists. - intros. - elim H0; intuition. - inversion H2. - intros x l Hrec f Hf. - generalize (Hf x); case (f x); simpl. - auto. - destruct 2 as [a (A1,A2)]. - inversion_clear A1. - rewrite <- (H a (X.eq_sym H0)) in A2; discriminate. - apply Hrec; auto. - exists a; auto. - Qed. - - Lemma exists_2 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. - simple induction s; simpl; auto; unfold Exists. - intros; discriminate. - intros x l Hrec f Hf. - case_eq (f x); intros. - exists x; auto. - destruct (Hrec f Hf H0) as [a (A1,A2)]. - exists a; auto. - Qed. - - Lemma partition_Inf_1 : - forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt), - Inf x s -> Inf x (fst (partition f s)). - Proof. - simple induction s; simpl. - intuition. - intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha. - generalize (Hrec H f a). - case (f x); case (partition f l); simpl. - auto. - intros; apply H2; apply Inf_lt with x; auto. - Qed. - - Lemma partition_Inf_2 : - forall (s : t) (Hs : Sort s) (f : elt -> bool) (x : elt), - Inf x s -> Inf x (snd (partition f s)). - Proof. - simple induction s; simpl. - intuition. - intros x l Hrec Hs f a Ha; inversion_clear Hs; inversion_clear Ha. - generalize (Hrec H f a). - case (f x); case (partition f l); simpl. - intros; apply H2; apply Inf_lt with x; auto. - auto. - Qed. - - Lemma partition_sort_1 : - forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (fst (partition f s)). - Proof. - simple induction s; simpl. - auto. - intros x l Hrec Hs f; inversion_clear Hs. - generalize (Hrec H f); generalize (partition_Inf_1 H f). - case (f x); case (partition f l); simpl; auto. - Qed. - - Lemma partition_sort_2 : - forall (s : t) (Hs : Sort s) (f : elt -> bool), Sort (snd (partition f s)). - Proof. - simple induction s; simpl. - auto. - intros x l Hrec Hs f; inversion_clear Hs. - generalize (Hrec H f); generalize (partition_Inf_2 H f). - case (f x); case (partition f l); simpl; auto. - Qed. - - Lemma partition_1 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> Equal (fst (partition f s)) (filter f s). - Proof. - simple induction s; simpl; auto; unfold Equal. - split; auto. - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - destruct (partition f l) as [s1 s2]; simpl; intros. - case (f x); simpl; auto. - split; inversion_clear 1; auto. - constructor 2; rewrite <- H; auto. - constructor 2; rewrite H; auto. - Qed. - - Lemma partition_2 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - simple induction s; simpl; auto; unfold Equal. - split; auto. - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - destruct (partition f l) as [s1 s2]; simpl; intros. - case (f x); simpl; auto. - split; inversion_clear 1; auto. - constructor 2; rewrite <- H; auto. - constructor 2; rewrite H; auto. - Qed. - - Definition eq : t -> t -> Prop := Equal. - - Lemma eq_refl : forall s : t, eq s s. - Proof. - unfold eq, Equal; intuition. - Qed. - - Lemma eq_sym : forall s s' : t, eq s s' -> eq s' s. - Proof. - unfold eq, Equal; intros; destruct (H a); intuition. - Qed. - - Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. - Proof. - unfold eq, Equal; intros; destruct (H a); destruct (H0 a); intuition. - Qed. - - Inductive lt : t -> t -> Prop := - | lt_nil : forall (x : elt) (s : t), lt nil (x :: s) - | lt_cons_lt : - forall (x y : elt) (s s' : t), X.lt x y -> lt (x :: s) (y :: s') - | lt_cons_eq : - forall (x y : elt) (s s' : t), - X.eq x y -> lt s s' -> lt (x :: s) (y :: s'). - Hint Constructors lt. - - Lemma lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''. - Proof. - intros s s' s'' H; generalize s''; clear s''; elim H. - intros x l s'' H'; inversion_clear H'; auto. - intros x x' l l' E s'' H'; inversion_clear H'; auto. - constructor; apply X.lt_trans with x'; auto. - constructor; apply lt_eq with x'; auto. - intros. - inversion_clear H3. - constructor; apply eq_lt with y; auto. - constructor 3; auto; apply X.eq_trans with y; auto. - Qed. - - Lemma lt_not_eq : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), lt s s' -> ~ eq s s'. - Proof. - unfold eq, Equal. - intros s s' Hs Hs' H; generalize Hs Hs'; clear Hs Hs'; elim H; intros; intro. - elim (H0 x); intros. - assert (X : In x nil); auto; inversion X. - inversion_clear Hs; inversion_clear Hs'. - elim (H1 x); intros. - assert (X : In x (y :: s'0)); auto; inversion_clear X. - order. - generalize (Sort_Inf_In H4 H5 H8); order. - inversion_clear Hs; inversion_clear Hs'. - elim H2; auto; split; intros. - generalize (Sort_Inf_In H4 H5 H8); intros. - elim (H3 a); intros. - assert (X : In a (y :: s'0)); auto; inversion_clear X; auto. - order. - generalize (Sort_Inf_In H6 H7 H8); intros. - elim (H3 a); intros. - assert (X : In a (x :: s0)); auto; inversion_clear X; auto. - order. - Qed. - - Definition compare : - forall (s s' : t) (Hs : Sort s) (Hs' : Sort s'), Compare lt eq s s'. - Proof. - simple induction s. - intros; case s'. - constructor 2; apply eq_refl. - constructor 1; auto. - intros a l Hrec s'; case s'. - constructor 3; auto. - intros a' l' Hs Hs'. - case (X.compare a a'); [ constructor 1 | idtac | constructor 3 ]; auto. - elim (Hrec l'); - [ constructor 1 - | constructor 2 - | constructor 3 - | inversion Hs - | inversion Hs' ]; auto. - generalize e; unfold eq, Equal; intuition; inversion_clear H. - constructor; apply X.eq_trans with a; auto. - destruct (e1 a0); auto. - constructor; apply X.eq_trans with a'; auto. - destruct (e1 a0); auto. - Defined. - - End ForNotations. - Hint Constructors lt. - -End Raw. - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of strictly ordered lists. *) +Require FSetCompat MSetList Orders OrdersAlt. Module Make (X: OrderedType) <: S with Module E := X. - - Module Raw := Raw X. - Module E := X. - - Record slist := {this :> Raw.t; sorted : sort E.lt this}. - Definition t := slist. - Definition elt := E.t. - - Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this). - Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'. - Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'. - Definition Empty (s:t) : Prop := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop)(s:t) : Prop := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop)(s:t) : Prop := exists x, In x s /\ P x. - - Definition mem (x : elt) (s : t) : bool := Raw.mem x s. - Definition add (x : elt)(s : t) : t := Build_slist (Raw.add_sort (sorted s) x). - Definition remove (x : elt)(s : t) : t := Build_slist (Raw.remove_sort (sorted s) x). - Definition singleton (x : elt) : t := Build_slist (Raw.singleton_sort x). - Definition union (s s' : t) : t := - Build_slist (Raw.union_sort (sorted s) (sorted s')). - Definition inter (s s' : t) : t := - Build_slist (Raw.inter_sort (sorted s) (sorted s')). - Definition diff (s s' : t) : t := - Build_slist (Raw.diff_sort (sorted s) (sorted s')). - Definition equal (s s' : t) : bool := Raw.equal s s'. - Definition subset (s s' : t) : bool := Raw.subset s s'. - Definition empty : t := Build_slist Raw.empty_sort. - Definition is_empty (s : t) : bool := Raw.is_empty s. - Definition elements (s : t) : list elt := Raw.elements s. - Definition min_elt (s : t) : option elt := Raw.min_elt s. - Definition max_elt (s : t) : option elt := Raw.max_elt s. - Definition choose (s : t) : option elt := Raw.choose s. - Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. - Definition cardinal (s : t) : nat := Raw.cardinal s. - Definition filter (f : elt -> bool) (s : t) : t := - Build_slist (Raw.filter_sort (sorted s) f). - Definition for_all (f : elt -> bool) (s : t) : bool := Raw.for_all f s. - Definition exists_ (f : elt -> bool) (s : t) : bool := Raw.exists_ f s. - Definition partition (f : elt -> bool) (s : t) : t * t := - let p := Raw.partition f s in - (Build_slist (this:=fst p) (Raw.partition_sort_1 (sorted s) f), - Build_slist (this:=snd p) (Raw.partition_sort_2 (sorted s) f)). - Definition eq (s s' : t) : Prop := Raw.eq s s'. - Definition lt (s s' : t) : Prop := Raw.lt s s'. - - Section Spec. - Variable s s' s'': t. - Variable x y : elt. - - Lemma In_1 : E.eq x y -> In x s -> In y s. - Proof. exact (fun H H' => Raw.MX.In_eq H H'). Qed. - - Lemma mem_1 : In x s -> mem x s = true. - Proof. exact (fun H => Raw.mem_1 s.(sorted) H). Qed. - Lemma mem_2 : mem x s = true -> In x s. - Proof. exact (fun H => Raw.mem_2 H). Qed. - - Lemma equal_1 : Equal s s' -> equal s s' = true. - Proof. exact (Raw.equal_1 s.(sorted) s'.(sorted)). Qed. - Lemma equal_2 : equal s s' = true -> Equal s s'. - Proof. exact (fun H => Raw.equal_2 H). Qed. - - Lemma subset_1 : Subset s s' -> subset s s' = true. - Proof. exact (Raw.subset_1 s.(sorted) s'.(sorted)). Qed. - Lemma subset_2 : subset s s' = true -> Subset s s'. - Proof. exact (fun H => Raw.subset_2 H). Qed. - - Lemma empty_1 : Empty empty. - Proof. exact Raw.empty_1. Qed. - - Lemma is_empty_1 : Empty s -> is_empty s = true. - Proof. exact (fun H => Raw.is_empty_1 H). Qed. - Lemma is_empty_2 : is_empty s = true -> Empty s. - Proof. exact (fun H => Raw.is_empty_2 H). Qed. - - Lemma add_1 : E.eq x y -> In y (add x s). - Proof. exact (fun H => Raw.add_1 s.(sorted) H). Qed. - Lemma add_2 : In y s -> In y (add x s). - Proof. exact (fun H => Raw.add_2 s.(sorted) x H). Qed. - Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. - Proof. exact (fun H => Raw.add_3 s.(sorted) H). Qed. - - Lemma remove_1 : E.eq x y -> ~ In y (remove x s). - Proof. exact (fun H => Raw.remove_1 s.(sorted) H). Qed. - Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). - Proof. exact (fun H H' => Raw.remove_2 s.(sorted) H H'). Qed. - Lemma remove_3 : In y (remove x s) -> In y s. - Proof. exact (fun H => Raw.remove_3 s.(sorted) H). Qed. - - Lemma singleton_1 : In y (singleton x) -> E.eq x y. - Proof. exact (fun H => Raw.singleton_1 H). Qed. - Lemma singleton_2 : E.eq x y -> In y (singleton x). - Proof. exact (fun H => Raw.singleton_2 H). Qed. - - Lemma union_1 : In x (union s s') -> In x s \/ In x s'. - Proof. exact (fun H => Raw.union_1 s.(sorted) s'.(sorted) H). Qed. - Lemma union_2 : In x s -> In x (union s s'). - Proof. exact (fun H => Raw.union_2 s.(sorted) s'.(sorted) H). Qed. - Lemma union_3 : In x s' -> In x (union s s'). - Proof. exact (fun H => Raw.union_3 s.(sorted) s'.(sorted) H). Qed. - - Lemma inter_1 : In x (inter s s') -> In x s. - Proof. exact (fun H => Raw.inter_1 s.(sorted) s'.(sorted) H). Qed. - Lemma inter_2 : In x (inter s s') -> In x s'. - Proof. exact (fun H => Raw.inter_2 s.(sorted) s'.(sorted) H). Qed. - Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). - Proof. exact (fun H => Raw.inter_3 s.(sorted) s'.(sorted) H). Qed. - - Lemma diff_1 : In x (diff s s') -> In x s. - Proof. exact (fun H => Raw.diff_1 s.(sorted) s'.(sorted) H). Qed. - Lemma diff_2 : In x (diff s s') -> ~ In x s'. - Proof. exact (fun H => Raw.diff_2 s.(sorted) s'.(sorted) H). Qed. - Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - Proof. exact (fun H => Raw.diff_3 s.(sorted) s'.(sorted) H). Qed. - - Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. exact (Raw.fold_1 s.(sorted)). Qed. - - Lemma cardinal_1 : cardinal s = length (elements s). - Proof. exact (Raw.cardinal_1 s.(sorted)). Qed. - - Section Filter. - - Variable f : elt -> bool. - - Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Proof. exact (@Raw.filter_1 s x f). Qed. - Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Proof. exact (@Raw.filter_2 s x f). Qed. - Lemma filter_3 : - compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. exact (@Raw.filter_3 s x f). Qed. - - Lemma for_all_1 : - compat_bool E.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Proof. exact (@Raw.for_all_1 s f). Qed. - Lemma for_all_2 : - compat_bool E.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - Proof. exact (@Raw.for_all_2 s f). Qed. - - Lemma exists_1 : - compat_bool E.eq f -> - Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. exact (@Raw.exists_1 s f). Qed. - Lemma exists_2 : - compat_bool E.eq f -> - exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. exact (@Raw.exists_2 s f). Qed. - - Lemma partition_1 : - compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). - Proof. exact (@Raw.partition_1 s f). Qed. - Lemma partition_2 : - compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. exact (@Raw.partition_2 s f). Qed. - - End Filter. - - Lemma elements_1 : In x s -> InA E.eq x (elements s). - Proof. exact (fun H => Raw.elements_1 H). Qed. - Lemma elements_2 : InA E.eq x (elements s) -> In x s. - Proof. exact (fun H => Raw.elements_2 H). Qed. - Lemma elements_3 : sort E.lt (elements s). - Proof. exact (Raw.elements_3 s.(sorted)). Qed. - Lemma elements_3w : NoDupA E.eq (elements s). - Proof. exact (Raw.elements_3w s.(sorted)). Qed. - - Lemma min_elt_1 : min_elt s = Some x -> In x s. - Proof. exact (fun H => Raw.min_elt_1 H). Qed. - Lemma min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. - Proof. exact (fun H => Raw.min_elt_2 s.(sorted) H). Qed. - Lemma min_elt_3 : min_elt s = None -> Empty s. - Proof. exact (fun H => Raw.min_elt_3 H). Qed. - - Lemma max_elt_1 : max_elt s = Some x -> In x s. - Proof. exact (fun H => Raw.max_elt_1 H). Qed. - Lemma max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. - Proof. exact (fun H => Raw.max_elt_2 s.(sorted) H). Qed. - Lemma max_elt_3 : max_elt s = None -> Empty s. - Proof. exact (fun H => Raw.max_elt_3 H). Qed. - - Lemma choose_1 : choose s = Some x -> In x s. - Proof. exact (fun H => Raw.choose_1 H). Qed. - Lemma choose_2 : choose s = None -> Empty s. - Proof. exact (fun H => Raw.choose_2 H). Qed. - Lemma choose_3 : choose s = Some x -> choose s' = Some y -> - Equal s s' -> E.eq x y. - Proof. exact (@Raw.choose_3 _ _ s.(sorted) s'.(sorted) x y). Qed. - - Lemma eq_refl : eq s s. - Proof. exact (Raw.eq_refl s). Qed. - Lemma eq_sym : eq s s' -> eq s' s. - Proof. exact (@Raw.eq_sym s s'). Qed. - Lemma eq_trans : eq s s' -> eq s' s'' -> eq s s''. - Proof. exact (@Raw.eq_trans s s' s''). Qed. - - Lemma lt_trans : lt s s' -> lt s' s'' -> lt s s''. - Proof. exact (@Raw.lt_trans s s' s''). Qed. - Lemma lt_not_eq : lt s s' -> ~ eq s s'. - Proof. exact (Raw.lt_not_eq s.(sorted) s'.(sorted)). Qed. - - Definition compare : Compare lt eq s s'. - Proof. - elim (Raw.compare s.(sorted) s'.(sorted)); - [ constructor 1 | constructor 2 | constructor 3 ]; - auto. - Defined. - - Definition eq_dec : { eq s s' } + { ~ eq s s' }. - Proof. - change eq with Equal. - case_eq (equal s s'); intro H; [left | right]. - apply equal_2; auto. - intro H'; rewrite equal_1 in H; auto; discriminate. - Defined. - - End Spec. - + Module X' := OrdersAlt.Update_OT X. + Module MSet := MSetList.Make X'. + Include FSetCompat.Backport_Sets X MSet. End Make. diff --git a/theories/FSets/FSetPositive.v b/theories/FSets/FSetPositive.v new file mode 100644 index 00000000..e5d55ac5 --- /dev/null +++ b/theories/FSets/FSetPositive.v @@ -0,0 +1,1173 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(** Efficient implementation of [FSetInterface.S] for positive keys, + inspired from the [FMapPositive] module. + + This module was adapted by Alexandre Ren, Damien Pous, and Thomas + Braibant (2010, LIG, CNRS, UMR 5217), from the [FMapPositive] + module of Pierre Letouzey and Jean-Christophe Filliâtre, which in + turn comes from the [FMap] framework of a work by Xavier Leroy and + Sandrine Blazy (used for building certified compilers). +*) + +Require Import Bool BinPos OrderedType OrderedTypeEx FSetInterface. + +Set Implicit Arguments. + +Local Open Scope lazy_bool_scope. +Local Open Scope positive_scope. + +Local Unset Elimination Schemes. +Local Unset Case Analysis Schemes. +Local Unset Boolean Equality Schemes. + + +Module PositiveSet <: S with Module E:=PositiveOrderedTypeBits. + + Module E:=PositiveOrderedTypeBits. + + Definition elt := positive. + + Inductive tree := + | Leaf : tree + | Node : tree -> bool -> tree -> tree. + + Scheme tree_ind := Induction for tree Sort Prop. + + Definition t := tree. + + Definition empty := Leaf. + + Fixpoint is_empty (m : t) : bool := + match m with + | Leaf => true + | Node l b r => negb b &&& is_empty l &&& is_empty r + end. + + Fixpoint mem (i : positive) (m : t) : bool := + match m with + | Leaf => false + | Node l o r => + match i with + | 1 => o + | i~0 => mem i l + | i~1 => mem i r + end + end. + + Fixpoint add (i : positive) (m : t) : t := + match m with + | Leaf => + match i with + | 1 => Node Leaf true Leaf + | i~0 => Node (add i Leaf) false Leaf + | i~1 => Node Leaf false (add i Leaf) + end + | Node l o r => + match i with + | 1 => Node l true r + | i~0 => Node (add i l) o r + | i~1 => Node l o (add i r) + end + end. + + Definition singleton i := add i empty. + + (** helper function to avoid creating empty trees that are not leaves *) + + Definition node l (b: bool) r := + if b then Node l b r else + match l,r with + | Leaf,Leaf => Leaf + | _,_ => Node l false r end. + + Fixpoint remove (i : positive) (m : t) : t := + match m with + | Leaf => Leaf + | Node l o r => + match i with + | 1 => node l false r + | i~0 => node (remove i l) o r + | i~1 => node l o (remove i r) + end + end. + + Fixpoint union (m m': t) := + match m with + | Leaf => m' + | Node l o r => + match m' with + | Leaf => m + | Node l' o' r' => Node (union l l') (o||o') (union r r') + end + end. + + Fixpoint inter (m m': t) := + match m with + | Leaf => Leaf + | Node l o r => + match m' with + | Leaf => Leaf + | Node l' o' r' => node (inter l l') (o&&o') (inter r r') + end + end. + + Fixpoint diff (m m': t) := + match m with + | Leaf => Leaf + | Node l o r => + match m' with + | Leaf => m + | Node l' o' r' => node (diff l l') (o&&negb o') (diff r r') + end + end. + + Fixpoint equal (m m': t): bool := + match m with + | Leaf => is_empty m' + | Node l o r => + match m' with + | Leaf => is_empty m + | Node l' o' r' => eqb o o' &&& equal l l' &&& equal r r' + end + end. + + Fixpoint subset (m m': t): bool := + match m with + | Leaf => true + | Node l o r => + match m' with + | Leaf => is_empty m + | Node l' o' r' => (negb o ||| o') &&& subset l l' &&& subset r r' + end + end. + + (** reverses [y] and concatenate it with [x] *) + + Fixpoint rev_append y x := + match y with + | 1 => x + | y~1 => rev_append y x~1 + | y~0 => rev_append y x~0 + end. + Infix "@" := rev_append (at level 60). + Definition rev x := x@1. + + Section Fold. + + Variables B : Type. + Variable f : positive -> B -> B. + + (** the additional argument, [i], records the current path, in + reverse order (this should be more efficient: we reverse this argument + only at present nodes only, rather than at each node of the tree). + we also use this convention in all functions below + *) + + Fixpoint xfold (m : t) (v : B) (i : positive) := + match m with + | Leaf => v + | Node l true r => + xfold r (f (rev i) (xfold l v i~0)) i~1 + | Node l false r => + xfold r (xfold l v i~0) i~1 + end. + Definition fold m i := xfold m i 1. + + End Fold. + + Section Quantifiers. + + Variable f : positive -> bool. + + Fixpoint xforall (m : t) (i : positive) := + match m with + | Leaf => true + | Node l o r => + (negb o ||| f (rev i)) &&& xforall r i~1 &&& xforall l i~0 + end. + Definition for_all m := xforall m 1. + + Fixpoint xexists (m : t) (i : positive) := + match m with + | Leaf => false + | Node l o r => (o &&& f (rev i)) ||| xexists r i~1 ||| xexists l i~0 + end. + Definition exists_ m := xexists m 1. + + Fixpoint xfilter (m : t) (i : positive) := + match m with + | Leaf => Leaf + | Node l o r => node (xfilter l i~0) (o &&& f (rev i)) (xfilter r i~1) + end. + Definition filter m := xfilter m 1. + + Fixpoint xpartition (m : t) (i : positive) := + match m with + | Leaf => (Leaf,Leaf) + | Node l o r => + let (lt,lf) := xpartition l i~0 in + let (rt,rf) := xpartition r i~1 in + if o then + let fi := f (rev i) in + (node lt fi rt, node lf (negb fi) rf) + else + (node lt false rt, node lf false rf) + end. + Definition partition m := xpartition m 1. + + End Quantifiers. + + (** uses [a] to accumulate values rather than doing a lot of concatenations *) + + Fixpoint xelements (m : t) (i : positive) (a: list positive) := + match m with + | Leaf => a + | Node l false r => xelements l i~0 (xelements r i~1 a) + | Node l true r => xelements l i~0 (rev i :: xelements r i~1 a) + end. + + Definition elements (m : t) := xelements m 1 nil. + + Fixpoint cardinal (m : t) : nat := + match m with + | Leaf => O + | Node l false r => (cardinal l + cardinal r)%nat + | Node l true r => S (cardinal l + cardinal r) + end. + + Definition omap (f: elt -> elt) x := + match x with + | None => None + | Some i => Some (f i) + end. + + (** would it be more efficient to use a path like in the above functions ? *) + + Fixpoint choose (m: t) := + match m with + | Leaf => None + | Node l o r => if o then Some 1 else + match choose l with + | None => omap xI (choose r) + | Some i => Some i~0 + end + end. + + Fixpoint min_elt (m: t) := + match m with + | Leaf => None + | Node l o r => + match min_elt l with + | None => if o then Some 1 else omap xI (min_elt r) + | Some i => Some i~0 + end + end. + + Fixpoint max_elt (m: t) := + match m with + | Leaf => None + | Node l o r => + match max_elt r with + | None => if o then Some 1 else omap xO (max_elt l) + | Some i => Some i~1 + end + end. + + (** lexicographic product, defined using a notation to keep things lazy *) + + Notation lex u v := match u with Eq => v | Lt => Lt | Gt => Gt end. + + Definition compare_bool a b := + match a,b with + | false, true => Lt + | true, false => Gt + | _,_ => Eq + end. + + Fixpoint compare_fun (m m': t): comparison := + match m,m' with + | Leaf,_ => if is_empty m' then Eq else Lt + | _,Leaf => if is_empty m then Eq else Gt + | Node l o r,Node l' o' r' => + lex (compare_bool o o') (lex (compare_fun l l') (compare_fun r r')) + end. + + + Definition In i t := mem i t = true. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + + Definition eq := Equal. + Definition lt m m' := compare_fun m m' = Lt. + + (** Specification of [In] *) + + Lemma In_1: forall s x y, E.eq x y -> In x s -> In y s. + Proof. intros s x y ->. trivial. Qed. + + (** Specification of [eq] *) + + Lemma eq_refl: forall s, eq s s. + Proof. unfold eq, Equal. reflexivity. Qed. + + Lemma eq_sym: forall s s', eq s s' -> eq s' s. + Proof. unfold eq, Equal. intros. symmetry. trivial. Qed. + + Lemma eq_trans: forall s s' s'', eq s s' -> eq s' s'' -> eq s s''. + Proof. unfold eq, Equal. intros ? ? ? H ? ?. rewrite H. trivial. Qed. + + (** Specification of [mem] *) + + Lemma mem_1: forall s x, In x s -> mem x s = true. + Proof. unfold In. trivial. Qed. + + Lemma mem_2: forall s x, mem x s = true -> In x s. + Proof. unfold In. trivial. Qed. + + (** Additional lemmas for mem *) + + Lemma mem_Leaf: forall x, mem x Leaf = false. + Proof. destruct x; trivial. Qed. + + (** Specification of [empty] *) + + Lemma empty_1 : Empty empty. + Proof. unfold Empty, In. intro. rewrite mem_Leaf. discriminate. Qed. + + (** Specification of node *) + + Lemma mem_node: forall x l o r, mem x (node l o r) = mem x (Node l o r). + Proof. + intros x l o r. + case o; trivial. + destruct l; trivial. + destruct r; trivial. + symmetry. destruct x. + apply mem_Leaf. + apply mem_Leaf. + reflexivity. + Qed. + Local Opaque node. + + (** Specification of [is_empty] *) + + Lemma is_empty_spec: forall s, Empty s <-> is_empty s = true. + Proof. + unfold Empty, In. + induction s as [|l IHl o r IHr]; simpl. + setoid_rewrite mem_Leaf. firstorder. + rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear IHl IHr. + destruct o; simpl; split. + intro H. elim (H 1). reflexivity. + intuition discriminate. + intro H. split. split. reflexivity. + intro a. apply (H a~0). + intro a. apply (H a~1). + intros H [a|a|]; apply H || intro; discriminate. + Qed. + + Lemma is_empty_1: forall s, Empty s -> is_empty s = true. + Proof. intro. rewrite is_empty_spec. trivial. Qed. + + Lemma is_empty_2: forall s, is_empty s = true -> Empty s. + Proof. intro. rewrite is_empty_spec. trivial. Qed. + + (** Specification of [subset] *) + + Lemma subset_Leaf_s: forall s, Leaf [<=] s. + Proof. intros s i Hi. elim (empty_1 Hi). Qed. + + Lemma subset_spec: forall s s', s [<=] s' <-> subset s s' = true. + Proof. + induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl. + split; intros. reflexivity. apply subset_Leaf_s. + + split; intros. reflexivity. apply subset_Leaf_s. + + rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- 2is_empty_spec. + destruct o; simpl. + split. + intro H. elim (@empty_1 1). apply H. reflexivity. + intuition discriminate. + split; intro H. + split. split. reflexivity. + unfold Empty. intros a H1. apply (@empty_1 (a~0)). apply H. assumption. + unfold Empty. intros a H1. apply (@empty_1 (a~1)). apply H. assumption. + destruct H as [[_ Hl] Hr]. + intros [i|i|] Hi. + elim (Hr i Hi). + elim (Hl i Hi). + discriminate. + + rewrite <- 2andb_lazy_alt, 2andb_true_iff, <- IHl, <- IHr. clear. + destruct o; simpl. + split; intro H. + split. split. + destruct o'; trivial. + specialize (H 1). unfold In in H. simpl in H. apply H. reflexivity. + intros i Hi. apply (H i~0). apply Hi. + intros i Hi. apply (H i~1). apply Hi. + destruct H as [[Ho' Hl] Hr]. rewrite Ho'. + intros i Hi. destruct i. + apply (Hr i). assumption. + apply (Hl i). assumption. + assumption. + split; intros. + split. split. reflexivity. + intros i Hi. apply (H i~0). apply Hi. + intros i Hi. apply (H i~1). apply Hi. + intros i Hi. destruct i; destruct H as [[H Hl] Hr]. + apply (Hr i). assumption. + apply (Hl i). assumption. + discriminate Hi. + Qed. + + + Lemma subset_1: forall s s', Subset s s' -> subset s s' = true. + Proof. intros s s'. apply -> subset_spec; trivial. Qed. + + Lemma subset_2: forall s s', subset s s' = true -> Subset s s'. + Proof. intros s s'. apply <- subset_spec; trivial. Qed. + + (** Specification of [equal] (via subset) *) + + Lemma equal_subset: forall s s', equal s s' = subset s s' && subset s' s. + Proof. + induction s as [|l IHl o r IHr]; intros [|l' o' r']; simpl; trivial. + destruct o. reflexivity. rewrite andb_comm. reflexivity. + rewrite <- 6andb_lazy_alt. rewrite eq_iff_eq_true. + rewrite 7andb_true_iff, eqb_true_iff. + rewrite IHl, IHr, 2andb_true_iff. clear IHl IHr. intuition subst. + destruct o'; reflexivity. + destruct o'; reflexivity. + destruct o; auto. destruct o'; trivial. + Qed. + + Lemma equal_spec: forall s s', Equal s s' <-> equal s s' = true. + Proof. + intros. rewrite equal_subset. rewrite andb_true_iff. + rewrite <- 2subset_spec. unfold Equal, Subset. firstorder. + Qed. + + Lemma equal_1: forall s s', Equal s s' -> equal s s' = true. + Proof. intros s s'. apply -> equal_spec; trivial. Qed. + + Lemma equal_2: forall s s', equal s s' = true -> Equal s s'. + Proof. intros s s'. apply <- equal_spec; trivial. Qed. + + Lemma eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. + Proof. + unfold eq. + intros. case_eq (equal s s'); intro H. + left. apply equal_2, H. + right. abstract (intro H'; rewrite (equal_1 H') in H; discriminate). + Defined. + + (** (Specified) definition of [compare] *) + + Lemma lex_Opp: forall u v u' v', u = CompOpp u' -> v = CompOpp v' -> + lex u v = CompOpp (lex u' v'). + Proof. intros ? ? u' ? -> ->. case u'; reflexivity. Qed. + + Lemma compare_bool_inv: forall b b', + compare_bool b b' = CompOpp (compare_bool b' b). + Proof. intros [|] [|]; reflexivity. Qed. + + Lemma compare_inv: forall s s', compare_fun s s' = CompOpp (compare_fun s' s). + Proof. + induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']; trivial. + unfold compare_fun. case is_empty; reflexivity. + unfold compare_fun. case is_empty; reflexivity. + simpl. rewrite compare_bool_inv. + case compare_bool; simpl; trivial; apply lex_Opp; auto. + Qed. + + Lemma lex_Eq: forall u v, lex u v = Eq <-> u=Eq /\ v=Eq. + Proof. intros u v; destruct u; intuition discriminate. Qed. + + Lemma compare_bool_Eq: forall b1 b2, + compare_bool b1 b2 = Eq <-> eqb b1 b2 = true. + Proof. intros [|] [|]; intuition discriminate. Qed. + + Lemma compare_equal: forall s s', compare_fun s s' = Eq <-> equal s s' = true. + Proof. + induction s as [|l IHl o r IHr]; destruct s' as [|l' o' r']. + simpl. tauto. + unfold compare_fun, equal. case is_empty; intuition discriminate. + unfold compare_fun, equal. case is_empty; intuition discriminate. + simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff. + rewrite <- IHl, <- IHr, <- compare_bool_Eq. clear IHl IHr. + rewrite and_assoc. rewrite <- 2lex_Eq. reflexivity. + Qed. + + + Lemma compare_gt: forall s s', compare_fun s s' = Gt -> lt s' s. + Proof. + unfold lt. intros s s'. rewrite compare_inv. + case compare_fun; trivial; intros; discriminate. + Qed. + + Lemma compare_eq: forall s s', compare_fun s s' = Eq -> eq s s'. + Proof. + unfold eq. intros s s'. rewrite compare_equal, equal_spec. trivial. + Qed. + + Lemma compare : forall s s' : t, Compare lt eq s s'. + Proof. + intros. case_eq (compare_fun s s'); intro H. + apply EQ. apply compare_eq, H. + apply LT. assumption. + apply GT. apply compare_gt, H. + Defined. + + Section lt_spec. + + Inductive ct: comparison -> comparison -> comparison -> Prop := + | ct_xxx: forall x, ct x x x + | ct_xex: forall x, ct x Eq x + | ct_exx: forall x, ct Eq x x + | ct_glx: forall x, ct Gt Lt x + | ct_lgx: forall x, ct Lt Gt x. + + Lemma ct_cxe: forall x, ct (CompOpp x) x Eq. + Proof. destruct x; constructor. Qed. + + Lemma ct_xce: forall x, ct x (CompOpp x) Eq. + Proof. destruct x; constructor. Qed. + + Lemma ct_lxl: forall x, ct Lt x Lt. + Proof. destruct x; constructor. Qed. + + Lemma ct_gxg: forall x, ct Gt x Gt. + Proof. destruct x; constructor. Qed. + + Lemma ct_xll: forall x, ct x Lt Lt. + Proof. destruct x; constructor. Qed. + + Lemma ct_xgg: forall x, ct x Gt Gt. + Proof. destruct x; constructor. Qed. + + Local Hint Constructors ct: ct. + Local Hint Resolve ct_cxe ct_xce ct_lxl ct_xll ct_gxg ct_xgg: ct. + Ltac ct := trivial with ct. + + Lemma ct_lex: forall u v w u' v' w', + ct u v w -> ct u' v' w' -> ct (lex u u') (lex v v') (lex w w'). + Proof. + intros u v w u' v' w' H H'. + inversion_clear H; inversion_clear H'; ct; destruct w; ct; destruct w'; ct. + Qed. + + Lemma ct_compare_bool: + forall a b c, ct (compare_bool a b) (compare_bool b c) (compare_bool a c). + Proof. + intros [|] [|] [|]; constructor. + Qed. + + Lemma compare_x_Leaf: forall s, + compare_fun s Leaf = if is_empty s then Eq else Gt. + Proof. + intros. rewrite compare_inv. simpl. case (is_empty s); reflexivity. + Qed. + + Lemma compare_empty_x: forall a, is_empty a = true -> + forall b, compare_fun a b = if is_empty b then Eq else Lt. + Proof. + induction a as [|l IHl o r IHr]; trivial. + destruct o. intro; discriminate. + simpl is_empty. rewrite <- andb_lazy_alt, andb_true_iff. + intros [Hl Hr]. + destruct b as [|l' [|] r']; simpl compare_fun; trivial. + rewrite Hl, Hr. trivial. + rewrite (IHl Hl), (IHr Hr). simpl. + case (is_empty l'); case (is_empty r'); trivial. + Qed. + + Lemma compare_x_empty: forall a, is_empty a = true -> + forall b, compare_fun b a = if is_empty b then Eq else Gt. + Proof. + setoid_rewrite <- compare_x_Leaf. + intros. rewrite 2(compare_inv b), (compare_empty_x _ H). reflexivity. + Qed. + + Lemma ct_compare_fun: + forall a b c, ct (compare_fun a b) (compare_fun b c) (compare_fun a c). + Proof. + induction a as [|l IHl o r IHr]; intros s' s''. + destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']; ct. + rewrite compare_inv. ct. + unfold compare_fun at 1. case_eq (is_empty (Node l' o' r')); intro H'. + rewrite (compare_empty_x _ H'). ct. + unfold compare_fun at 2. case_eq (is_empty (Node l'' o'' r'')); intro H''. + rewrite (compare_x_empty _ H''), H'. ct. + ct. + + destruct s' as [|l' o' r']; destruct s'' as [|l'' o'' r'']. + ct. + unfold compare_fun at 2. rewrite compare_x_Leaf. + case_eq (is_empty (Node l o r)); intro H. + rewrite (compare_empty_x _ H). ct. + case_eq (is_empty (Node l'' o'' r'')); intro H''. + rewrite (compare_x_empty _ H''), H. ct. + ct. + + rewrite 2 compare_x_Leaf. + case_eq (is_empty (Node l o r)); intro H. + rewrite compare_inv, (compare_x_empty _ H). ct. + case_eq (is_empty (Node l' o' r')); intro H'. + rewrite (compare_x_empty _ H'), H. ct. + ct. + + simpl compare_fun. apply ct_lex. apply ct_compare_bool. + apply ct_lex; trivial. + Qed. + + End lt_spec. + + Lemma lt_trans: forall s s' s'', lt s s' -> lt s' s'' -> lt s s''. + Proof. + unfold lt. intros a b c. assert (H := ct_compare_fun a b c). + inversion_clear H; trivial; intros; discriminate. + Qed. + + Lemma lt_not_eq: forall s s', lt s s' -> ~ eq s s'. + Proof. + unfold lt, eq. intros s s' H H'. + rewrite equal_spec, <- compare_equal in H'. congruence. + Qed. + + (** Specification of [add] *) + + Lemma add_spec: forall x y s, In y (add x s) <-> x=y \/ In y s. + Proof. + unfold In. induction x; intros [y|y|] [|l o r]; simpl mem; + try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; intuition congruence. + Qed. + + Lemma add_1: forall s x y, x = y -> In y (add x s). + Proof. intros. apply <- add_spec. left. assumption. Qed. + + Lemma add_2: forall s x y, In y s -> In y (add x s). + Proof. intros. apply <- add_spec. right. assumption. Qed. + + Lemma add_3: forall s x y, x<>y -> In y (add x s) -> In y s. + Proof. + intros s x y H. rewrite add_spec. intros [->|?]; trivial. elim H; trivial. + Qed. + + (** Specification of [remove] *) + + Lemma remove_spec: forall x y s, In y (remove x s) <-> x<>y /\ In y s. + Proof. + unfold In. + induction x; intros [y|y|] [|l o r]; simpl remove; rewrite ?mem_node; + simpl mem; try (rewrite IHx; clear IHx); rewrite ?mem_Leaf; + intuition congruence. + Qed. + + Lemma remove_1: forall s x y, x=y -> ~ In y (remove x s). + Proof. intros. rewrite remove_spec. tauto. Qed. + + Lemma remove_2: forall s x y, x<>y -> In y s -> In y (remove x s). + Proof. intros. rewrite remove_spec. split; assumption. Qed. + + Lemma remove_3: forall s x y, In y (remove x s) -> In y s. + Proof. intros s x y. rewrite remove_spec. tauto. Qed. + + (** Specification of [singleton] *) + + Lemma singleton_1: forall x y, In y (singleton x) -> x=y. + Proof. + unfold singleton. intros x y. rewrite add_spec. + unfold In. rewrite mem_Leaf. intuition discriminate. + Qed. + + Lemma singleton_2: forall x y, x = y -> In y (singleton x). + Proof. + unfold singleton. intros. apply add_1. assumption. + Qed. + + (** Specification of [union] *) + + Lemma union_spec: forall x s s', In x (union s s') <-> In x s \/ In x s'. + Proof. + unfold In. + induction x; destruct s; destruct s'; simpl union; simpl mem; + try (rewrite IHx; clear IHx); try intuition congruence. + apply orb_true_iff. + Qed. + + Lemma union_1: forall s s' x, In x (union s s') -> In x s \/ In x s'. + Proof. intros. apply -> union_spec. assumption. Qed. + + Lemma union_2: forall s s' x, In x s -> In x (union s s'). + Proof. intros. apply <- union_spec. left. assumption. Qed. + + Lemma union_3: forall s s' x, In x s' -> In x (union s s'). + Proof. intros. apply <- union_spec. right. assumption. Qed. + + (** Specification of [inter] *) + + Lemma inter_spec: forall x s s', In x (inter s s') <-> In x s /\ In x s'. + Proof. + unfold In. + induction x; destruct s; destruct s'; simpl inter; rewrite ?mem_node; + simpl mem; try (rewrite IHx; clear IHx); try intuition congruence. + apply andb_true_iff. + Qed. + + Lemma inter_1: forall s s' x, In x (inter s s') -> In x s. + Proof. intros s s' x. rewrite inter_spec. tauto. Qed. + + Lemma inter_2: forall s s' x, In x (inter s s') -> In x s'. + Proof. intros s s' x. rewrite inter_spec. tauto. Qed. + + Lemma inter_3: forall s s' x, In x s -> In x s' -> In x (inter s s'). + Proof. intros. rewrite inter_spec. split; assumption. Qed. + + (** Specification of [diff] *) + + Lemma diff_spec: forall x s s', In x (diff s s') <-> In x s /\ ~ In x s'. + Proof. + unfold In. + induction x; destruct s; destruct s' as [|l' o' r']; simpl diff; + rewrite ?mem_node; simpl mem; + try (rewrite IHx; clear IHx); try intuition congruence. + rewrite andb_true_iff. destruct o'; intuition discriminate. + Qed. + + Lemma diff_1: forall s s' x, In x (diff s s') -> In x s. + Proof. intros s s' x. rewrite diff_spec. tauto. Qed. + + Lemma diff_2: forall s s' x, In x (diff s s') -> ~ In x s'. + Proof. intros s s' x. rewrite diff_spec. tauto. Qed. + + Lemma diff_3: forall s s' x, In x s -> ~ In x s' -> In x (diff s s'). + Proof. intros. rewrite diff_spec. split; assumption. Qed. + + (** Specification of [fold] *) + + Lemma fold_1: forall s (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + Proof. + unfold fold, elements. intros s A i f. revert s i. + set (f' := fun a e => f e a). + assert (H: forall s i j acc, + fold_left f' acc (xfold f s i j) = + fold_left f' (xelements s j acc) i). + + induction s as [|l IHl o r IHr]; intros; trivial. + destruct o; simpl xelements; simpl xfold. + rewrite IHr, <- IHl. reflexivity. + rewrite IHr. apply IHl. + + intros. exact (H s i 1 nil). + Qed. + + (** Specification of [cardinal] *) + + Lemma cardinal_1: forall s, cardinal s = length (elements s). + Proof. + unfold elements. + assert (H: forall s j acc, + (cardinal s + length acc)%nat = length (xelements s j acc)). + + induction s as [|l IHl b r IHr]; intros j acc; simpl; trivial. destruct b. + rewrite <- IHl. simpl. rewrite <- IHr. + rewrite <- plus_n_Sm, Plus.plus_assoc. reflexivity. + rewrite <- IHl, <- IHr. rewrite Plus.plus_assoc. reflexivity. + + intros. rewrite <- H. simpl. rewrite Plus.plus_comm. reflexivity. + Qed. + + (** Specification of [filter] *) + + Lemma xfilter_spec: forall f s x i, + In x (xfilter f s i) <-> In x s /\ f (i@x) = true. + Proof. + intro f. unfold In. + induction s as [|l IHl o r IHr]; intros x i; simpl xfilter. + rewrite mem_Leaf. intuition discriminate. + rewrite mem_node. destruct x; simpl. + rewrite IHr. reflexivity. + rewrite IHl. reflexivity. + rewrite <- andb_lazy_alt. apply andb_true_iff. + Qed. + + Lemma filter_1 : forall s x f, compat_bool E.eq f -> + In x (filter f s) -> In x s. + Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. + + Lemma filter_2 : forall s x f, compat_bool E.eq f -> + In x (filter f s) -> f x = true. + Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. + + Lemma filter_3 : forall s x f, compat_bool E.eq f -> In x s -> + f x = true -> In x (filter f s). + Proof. unfold filter. intros s x f _. rewrite xfilter_spec. tauto. Qed. + + + (** Specification of [for_all] *) + + Lemma xforall_spec: forall f s i, + xforall f s i = true <-> For_all (fun x => f (i@x) = true) s. + Proof. + unfold For_all, In. intro f. + induction s as [|l IHl o r IHr]; intros i; simpl. + setoid_rewrite mem_Leaf. intuition discriminate. + rewrite <- 2andb_lazy_alt, <- orb_lazy_alt, 2 andb_true_iff. + rewrite IHl, IHr. clear IHl IHr. + split. + intros [[Hi Hr] Hl] x. destruct x; simpl; intro H. + apply Hr, H. + apply Hl, H. + rewrite H in Hi. assumption. + intro H; intuition. + specialize (H 1). destruct o. apply H. reflexivity. reflexivity. + apply H. assumption. + apply H. assumption. + Qed. + + Lemma for_all_1 : forall s f, compat_bool E.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true. + Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed. + + Lemma for_all_2 : forall s f, compat_bool E.eq f -> + for_all f s = true -> For_all (fun x => f x = true) s. + Proof. intros s f _. unfold for_all. rewrite xforall_spec. trivial. Qed. + + + (** Specification of [exists] *) + + Lemma xexists_spec: forall f s i, + xexists f s i = true <-> Exists (fun x => f (i@x) = true) s. + Proof. + unfold Exists, In. intro f. + induction s as [|l IHl o r IHr]; intros i; simpl. + setoid_rewrite mem_Leaf. firstorder. + rewrite <- 2orb_lazy_alt, 2orb_true_iff, <- andb_lazy_alt, andb_true_iff. + rewrite IHl, IHr. clear IHl IHr. + split. + intros [[Hi|[x Hr]]|[x Hl]]. + exists 1. exact Hi. + exists x~1. exact Hr. + exists x~0. exact Hl. + intros [[x|x|] H]; eauto. + Qed. + + Lemma exists_1 : forall s f, compat_bool E.eq f -> + Exists (fun x => f x = true) s -> exists_ f s = true. + Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed. + + Lemma exists_2 : forall s f, compat_bool E.eq f -> + exists_ f s = true -> Exists (fun x => f x = true) s. + Proof. intros s f _. unfold exists_. rewrite xexists_spec. trivial. Qed. + + + (** Specification of [partition] *) + + Lemma partition_filter : forall s f, + partition f s = (filter f s, filter (fun x => negb (f x)) s). + Proof. + unfold partition, filter. intros s f. generalize 1 as j. + induction s as [|l IHl o r IHr]; intro j. + reflexivity. + destruct o; simpl; rewrite IHl, IHr; reflexivity. + Qed. + + Lemma partition_1 : forall s f, compat_bool E.eq f -> + Equal (fst (partition f s)) (filter f s). + Proof. intros. rewrite partition_filter. apply eq_refl. Qed. + + Lemma partition_2 : forall s f, compat_bool E.eq f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. intros. rewrite partition_filter. apply eq_refl. Qed. + + + (** Specification of [elements] *) + + Notation InL := (InA E.eq). + + Lemma xelements_spec: forall s j acc y, + InL y (xelements s j acc) + <-> + InL y acc \/ exists x, y=(j@x) /\ mem x s = true. + Proof. + induction s as [|l IHl o r IHr]; simpl. + intros. split; intro H. + left. assumption. + destruct H as [H|[x [Hx Hx']]]. assumption. elim (empty_1 Hx'). + + intros j acc y. case o. + rewrite IHl. rewrite InA_cons. rewrite IHr. clear IHl IHr. split. + intros [[H|[H|[x [-> H]]]]|[x [-> H]]]; eauto. + right. exists x~1. auto. + right. exists x~0. auto. + intros [H|[x [-> H]]]. + eauto. + destruct x. + left. right. right. exists x; auto. + right. exists x; auto. + left. left. reflexivity. + + rewrite IHl, IHr. clear IHl IHr. split. + intros [[H|[x [-> H]]]|[x [-> H]]]. + eauto. + right. exists x~1. auto. + right. exists x~0. auto. + intros [H|[x [-> H]]]. + eauto. + destruct x. + left. right. exists x; auto. + right. exists x; auto. + discriminate. + Qed. + + Lemma elements_1: forall s x, In x s -> InL x (elements s). + Proof. + unfold elements, In. intros. + rewrite xelements_spec. right. exists x. auto. + Qed. + + Lemma elements_2: forall s x, InL x (elements s) -> In x s. + Proof. + unfold elements, In. intros s x H. + rewrite xelements_spec in H. destruct H as [H|[y [H H']]]. + inversion_clear H. + rewrite H. assumption. + Qed. + + Lemma lt_rev_append: forall j x y, E.lt x y -> E.lt (j@x) (j@y). + Proof. induction j; intros; simpl; auto. Qed. + + Lemma elements_3: forall s, sort E.lt (elements s). + Proof. + unfold elements. + assert (H: forall s j acc, + sort E.lt acc -> + (forall x y, In x s -> InL y acc -> E.lt (j@x) y) -> + sort E.lt (xelements s j acc)). + + induction s as [|l IHl o r IHr]; simpl; trivial. + intros j acc Hacc Hsacc. destruct o. + apply IHl. constructor. + apply IHr. apply Hacc. + intros x y Hx Hy. apply Hsacc; assumption. + case_eq (xelements r j~1 acc). constructor. + intros z q H. constructor. + assert (H': InL z (xelements r j~1 acc)). + rewrite H. constructor. reflexivity. + clear H q. rewrite xelements_spec in H'. destruct H' as [Hy|[x [-> Hx]]]. + apply (Hsacc 1 z); trivial. reflexivity. + simpl. apply lt_rev_append. exact I. + intros x y Hx Hy. inversion_clear Hy. + rewrite H. simpl. apply lt_rev_append. exact I. + rewrite xelements_spec in H. destruct H as [Hy|[z [-> Hy]]]. + apply Hsacc; assumption. + simpl. apply lt_rev_append. exact I. + + apply IHl. apply IHr. apply Hacc. + intros x y Hx Hy. apply Hsacc; assumption. + intros x y Hx Hy. rewrite xelements_spec in Hy. + destruct Hy as [Hy|[z [-> Hy]]]. + apply Hsacc; assumption. + simpl. apply lt_rev_append. exact I. + + intros. apply H. constructor. + intros x y _ H'. inversion H'. + Qed. + + Lemma elements_3w: forall s, NoDupA E.eq (elements s). + Proof. + intro. apply SortA_NoDupA with E.lt. + constructor. + intro. apply E.eq_refl. + intro. apply E.eq_sym. + intro. apply E.eq_trans. + constructor. + intros x H. apply E.lt_not_eq in H. apply H. reflexivity. + intro. apply E.lt_trans. + intros ? ? <- ? ? <-. reflexivity. + apply elements_3. + Qed. + + + (** Specification of [choose] *) + + Lemma choose_1: forall s x, choose s = Some x -> In x s. + Proof. + induction s as [| l IHl o r IHr]; simpl. + intros. discriminate. + destruct o. + intros x H. injection H; intros; subst. reflexivity. + revert IHl. case choose. + intros p Hp x H. injection H; intros; subst; clear H. apply Hp. + reflexivity. + intros _ x. revert IHr. case choose. + intros p Hp H. injection H; intros; subst; clear H. apply Hp. + reflexivity. + intros. discriminate. + Qed. + + Lemma choose_2: forall s, choose s = None -> Empty s. + Proof. + unfold Empty, In. intros s H. + induction s as [|l IHl o r IHr]. + intro. apply empty_1. + destruct o. + discriminate. + simpl in H. destruct (choose l). + discriminate. + destruct (choose r). + discriminate. + intros [a|a|]. + apply IHr. reflexivity. + apply IHl. reflexivity. + discriminate. + Qed. + + Lemma choose_empty: forall s, is_empty s = true -> choose s = None. + Proof. + intros s Hs. case_eq (choose s); trivial. + intros p Hp. apply choose_1 in Hp. apply is_empty_2 in Hs. elim (Hs _ Hp). + Qed. + + Lemma choose_3': forall s s', Equal s s' -> choose s = choose s'. + Proof. + setoid_rewrite equal_spec. + induction s as [|l IHl o r IHr]. + intros. symmetry. apply choose_empty. assumption. + + destruct s' as [|l' o' r']. + generalize (Node l o r) as s. simpl. intros. apply choose_empty. + rewrite <- equal_spec in H. apply eq_sym in H. rewrite equal_spec in H. + assumption. + + simpl. rewrite <- 2andb_lazy_alt, 2andb_true_iff, eqb_true_iff. + intros [[<- Hl] Hr]. rewrite (IHl _ Hl), (IHr _ Hr). reflexivity. + Qed. + + Lemma choose_3: forall s s' x y, + choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. + Proof. intros s s' x y Hx Hy H. apply choose_3' in H. congruence. Qed. + + + (** Specification of [min_elt] *) + + Lemma min_elt_1: forall s x, min_elt s = Some x -> In x s. + Proof. + unfold In. + induction s as [| l IHl o r IHr]; simpl. + intros. discriminate. + intros x. destruct (min_elt l); intros. + injection H. intros <-. apply IHl. reflexivity. + destruct o; simpl. + injection H. intros <-. reflexivity. + destruct (min_elt r); simpl in *. + injection H. intros <-. apply IHr. reflexivity. + discriminate. + Qed. + + Lemma min_elt_3: forall s, min_elt s = None -> Empty s. + Proof. + unfold Empty, In. intros s H. + induction s as [|l IHl o r IHr]. + intro. apply empty_1. + intros [a|a|]. + apply IHr. revert H. clear. simpl. destruct (min_elt r); trivial. + case min_elt; intros; try discriminate. destruct o; discriminate. + apply IHl. revert H. clear. simpl. destruct (min_elt l); trivial. + intro; discriminate. + revert H. clear. simpl. case min_elt; intros; try discriminate. + destruct o; discriminate. + Qed. + + Lemma min_elt_2: forall s x y, min_elt s = Some x -> In y s -> ~ E.lt y x. + Proof. + unfold In. + induction s as [|l IHl o r IHr]; intros x y H H'. + discriminate. + simpl in H. case_eq (min_elt l). + intros p Hp. rewrite Hp in H. injection H; intros <-. + destruct y as [z|z|]; simpl; intro; trivial. apply (IHl p z); trivial. + intro Hp; rewrite Hp in H. apply min_elt_3 in Hp. + destruct o. + injection H. intros <- Hl. clear H. + destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). + + destruct (min_elt r). + injection H. intros <-. clear H. + destruct y as [z|z|]. + apply (IHr p z); trivial. + elim (Hp _ H'). + discriminate. + discriminate. + Qed. + + + (** Specification of [max_elt] *) + + Lemma max_elt_1: forall s x, max_elt s = Some x -> In x s. + Proof. + unfold In. + induction s as [| l IHl o r IHr]; simpl. + intros. discriminate. + intros x. destruct (max_elt r); intros. + injection H. intros <-. apply IHr. reflexivity. + destruct o; simpl. + injection H. intros <-. reflexivity. + destruct (max_elt l); simpl in *. + injection H. intros <-. apply IHl. reflexivity. + discriminate. + Qed. + + Lemma max_elt_3: forall s, max_elt s = None -> Empty s. + Proof. + unfold Empty, In. intros s H. + induction s as [|l IHl o r IHr]. + intro. apply empty_1. + intros [a|a|]. + apply IHr. revert H. clear. simpl. destruct (max_elt r); trivial. + intro; discriminate. + apply IHl. revert H. clear. simpl. destruct (max_elt l); trivial. + case max_elt; intros; try discriminate. destruct o; discriminate. + revert H. clear. simpl. case max_elt; intros; try discriminate. + destruct o; discriminate. + Qed. + + Lemma max_elt_2: forall s x y, max_elt s = Some x -> In y s -> ~ E.lt x y. + Proof. + unfold In. + induction s as [|l IHl o r IHr]; intros x y H H'. + discriminate. + simpl in H. case_eq (max_elt r). + intros p Hp. rewrite Hp in H. injection H; intros <-. + destruct y as [z|z|]; simpl; intro; trivial. apply (IHr p z); trivial. + intro Hp; rewrite Hp in H. apply max_elt_3 in Hp. + destruct o. + injection H. intros <- Hl. clear H. + destruct y as [z|z|]; simpl; trivial. elim (Hp _ H'). + + destruct (max_elt l). + injection H. intros <-. clear H. + destruct y as [z|z|]. + elim (Hp _ H'). + apply (IHl p z); trivial. + discriminate. + discriminate. + Qed. + +End PositiveSet. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 8dc7fbd9..84c26dac 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -6,14 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetProperties.v 11720 2008-12-28 07:12:15Z letouzey $ *) +(* $Id$ *) (** * Finite sets library *) (** This functor derives additional properties from [FSetInterface.S]. - Contrary to the functor in [FSetEqProperties] it uses + Contrary to the functor in [FSetEqProperties] it uses predicates over sets instead of sets operations, i.e. - [In x s] instead of [mem x s=true], + [In x s] instead of [mem x s=true], [Equal s s'] instead of [equal s s'=true], etc. *) Require Export FSetInterface. @@ -21,7 +21,7 @@ Require Import DecidableTypeEx FSetFacts FSetDecide. Set Implicit Arguments. Unset Strict Implicit. -Hint Unfold transpose compat_op. +Hint Unfold transpose compat_op Proper respectful. Hint Extern 1 (Equivalence _) => constructor; congruence. (** First, a functor for Weak Sets in functorial version. *) @@ -47,7 +47,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). fsetdec. fsetdec. Qed. - + Ltac expAdd := repeat rewrite Add_Equal. Section BasicProperties. @@ -64,7 +64,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. Proof. fsetdec. Qed. - Lemma subset_refl : s[<=]s. + Lemma subset_refl : s[<=]s. Proof. fsetdec. Qed. Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. @@ -84,7 +84,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. Proof. fsetdec. Qed. - + Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. Proof. fsetdec. Qed. @@ -93,7 +93,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. Proof. fsetdec. Qed. - + Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. Proof. intuition fsetdec. Qed. @@ -105,7 +105,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma add_equal : In x s -> add x s [=] s. Proof. fsetdec. Qed. - + Lemma add_add : add x (add x' s) [=] add x' (add x s). Proof. fsetdec. Qed. @@ -149,11 +149,11 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma union_add : union (add x s) s' [=] add x (union s s'). Proof. fsetdec. Qed. - Lemma union_remove_add_1 : + Lemma union_remove_add_1 : union (remove x s) (add x s') [=] union (add x s) (remove x s'). Proof. fsetdec. Qed. - Lemma union_remove_add_2 : In x s -> + Lemma union_remove_add_2 : In x s -> union (remove x s) (add x s') [=] union s s'. Proof. fsetdec. Qed. @@ -167,10 +167,10 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. fsetdec. Qed. Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. - Proof. fsetdec. Qed. + Proof. fsetdec. Qed. Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. - Proof. fsetdec. Qed. + Proof. fsetdec. Qed. Lemma empty_union_1 : Empty s -> union s s' [=] s'. Proof. fsetdec. Qed. @@ -178,7 +178,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma empty_union_2 : Empty s -> union s' s [=] s'. Proof. fsetdec. Qed. - Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). + Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). Proof. fsetdec. Qed. Lemma inter_sym : inter s s' [=] inter s' s. @@ -224,7 +224,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. Proof. fsetdec. Qed. - Lemma empty_diff_1 : Empty s -> Empty (diff s s'). + Lemma empty_diff_1 : Empty s -> Empty (diff s s'). Proof. fsetdec. Qed. Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. @@ -240,7 +240,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). remove x s [=] diff s (singleton x). Proof. fsetdec. Qed. - Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. + Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. Proof. fsetdec. Qed. Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. @@ -249,19 +249,19 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma Add_add : Add x s (add x s). Proof. expAdd; fsetdec. Qed. - Lemma Add_remove : In x s -> Add x (remove x s) s. + Lemma Add_remove : In x s -> Add x (remove x s) s. Proof. expAdd; fsetdec. Qed. Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). - Proof. expAdd; fsetdec. Qed. + Proof. expAdd; fsetdec. Qed. Lemma inter_Add : In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). - Proof. expAdd; fsetdec. Qed. + Proof. expAdd; fsetdec. Qed. Lemma union_Equal : In x s'' -> Add x s s' -> union s s'' [=] union s' s''. - Proof. expAdd; fsetdec. Qed. + Proof. expAdd; fsetdec. Qed. Lemma inter_Add_2 : ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. @@ -270,16 +270,16 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). End BasicProperties. Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. - Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym - subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 + Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym + subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal - remove_equal singleton_equal_add union_subset_equal union_equal_1 - union_equal_2 union_assoc add_union_singleton union_add union_subset_1 + remove_equal singleton_equal_add union_subset_equal union_equal_1 + union_equal_2 union_assoc add_union_singleton union_add union_subset_1 union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2 inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2 - empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 - empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union - inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal + empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 + empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union + inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove Equal_remove add_add : set. @@ -358,9 +358,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' -> P s' a -> P s'' (f x a)). intros; eapply Pstep; eauto. - rewrite elements_iff, <- InA_rev; auto. + rewrite elements_iff, <- InA_rev; auto with *. assert (Hdup : NoDup l) by - (unfold l; eauto using elements_3w, NoDupA_rev). + (unfold l; eauto using elements_3w, NoDupA_rev with *). assert (Hsame : forall x, In x s <-> InA x l) by (unfold l; intros; rewrite elements_iff, InA_rev; intuition). clear Pstep; clearbody l; revert s Hsame; induction l. @@ -429,7 +429,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). do 2 rewrite fold_1, <- fold_left_rev_right. set (l:=rev (elements s)). assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by - (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto). + (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with *). clearbody l; clear Rstep s. induction l; simpl; auto. Qed. @@ -481,8 +481,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). fold f s i = fold_right f i l. Proof. intros; exists (rev (elements s)); split. - apply NoDupA_rev; auto with set. - exact E.eq_trans. + apply NoDupA_rev; auto with *. split; intros. rewrite elements_iff; do 2 rewrite InA_alt. split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. @@ -504,7 +503,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). generalize H H2; clear H H2; case l; simpl; intros. reflexivity. elim (H e). - elim (H2 e); intuition. + elim (H2 e); intuition. Qed. Lemma fold_2 : @@ -514,17 +513,16 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). transpose eqA f -> ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). Proof. - intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); + intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. - apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto. - eauto. + apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto with *. rewrite <- Hl1; auto. - intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; + intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; rewrite (H2 a); intuition. Qed. - (** In fact, [fold] on empty sets is more than equivalent to + (** In fact, [fold] on empty sets is more than equivalent to the initial element, it is Leibniz-equal to it. *) Lemma fold_1b : @@ -541,26 +539,27 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). - Lemma fold_commutes : forall i s x, + Lemma fold_commutes : forall i s x, eqA (fold f s (f x i)) (f x (fold f s i)). Proof. intros. apply fold_rel with (R:=fun u v => eqA u (f x v)); intros. reflexivity. - transitivity (f x0 (f x b)); auto. + transitivity (f x0 (f x b)); auto. apply Comp; auto with *. Qed. (** ** Fold is a morphism *) - Lemma fold_init : forall i i' s, eqA i i' -> + Lemma fold_init : forall i i' s, eqA i i' -> eqA (fold f s i) (fold f s i'). Proof. intros. apply fold_rel with (R:=eqA); auto. + intros; apply Comp; auto with *. Qed. - Lemma fold_equal : + Lemma fold_equal : forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). - Proof. + Proof. intros i s; pattern s; apply set_induction; clear s; intros. transitivity i. apply fold_1; auto. @@ -576,23 +575,23 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). (** ** Fold and other set operators *) Lemma fold_empty : forall i, fold f empty i = i. - Proof. + Proof. intros i; apply fold_1b; auto with set. Qed. - Lemma fold_add : forall i s x, ~In x s -> + Lemma fold_add : forall i s x, ~In x s -> eqA (fold f (add x s) i) (f x (fold f s i)). - Proof. + Proof. intros; apply fold_2 with (eqA := eqA); auto with set. Qed. - Lemma add_fold : forall i s x, In x s -> + Lemma add_fold : forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply fold_equal; auto with set. Qed. - Lemma remove_fold_1: forall i s x, In x s -> + Lemma remove_fold_1: forall i s x, In x s -> eqA (f x (fold f (remove x s) i)) (fold f s i). Proof. intros. @@ -600,7 +599,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_2 with (eqA:=eqA); auto with set. Qed. - Lemma remove_fold_2: forall i s x, ~In x s -> + Lemma remove_fold_2: forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros. @@ -620,7 +619,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). symmetry; apply fold_1; auto. rename s'0 into s''. destruct (In_dec x s'). - (* In x s' *) + (* In x s' *) transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. apply fold_init; auto. apply fold_2 with (eqA:=eqA); auto with set. @@ -646,7 +645,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). symmetry; apply fold_2 with (eqA:=eqA); auto. Qed. - Lemma fold_diff_inter : forall i s s', + Lemma fold_diff_inter : forall i s s', eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). Proof. intros. @@ -659,7 +658,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_1; auto with set. Qed. - Lemma fold_union: forall i s s', + Lemma fold_union: forall i s s', (forall x, ~(In x s/\In x s')) -> eqA (fold f (union s s') i) (fold f s (fold f s' i)). Proof. @@ -696,9 +695,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Lemma cardinal_0 : forall s, exists l : list elt, NoDupA E.eq l /\ - (forall x : elt, In x s <-> InA E.eq x l) /\ + (forall x : elt, In x s <-> InA E.eq x l) /\ cardinal s = length l. - Proof. + Proof. intros; exists (elements s); intuition; apply cardinal_1. Qed. @@ -724,32 +723,32 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). destruct (elements s); intuition; discriminate. Qed. - Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. + Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. Proof. - intros; rewrite cardinal_Empty; auto. + intros; rewrite cardinal_Empty; auto. Qed. Hint Resolve cardinal_inv_1. - + Lemma cardinal_inv_2 : forall s n, cardinal s = S n -> { x : elt | In x s }. - Proof. + Proof. intros; rewrite M.cardinal_1 in H. generalize (elements_2 (s:=s)). - destruct (elements s); try discriminate. + destruct (elements s); try discriminate. exists e; auto. Qed. Lemma cardinal_inv_2b : forall s, cardinal s <> 0 -> { x : elt | In x s }. Proof. - intro; generalize (@cardinal_inv_2 s); destruct cardinal; + intro; generalize (@cardinal_inv_2 s); destruct cardinal; [intuition|eauto]. Qed. (** ** Cardinal is a morphism *) Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. - Proof. + Proof. symmetry. remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. induction n; intros. @@ -794,8 +793,8 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_diff_inter with (eqA:=@Logic.eq nat); auto. Qed. - Lemma union_cardinal: - forall s s', (forall x, ~(In x s/\In x s')) -> + Lemma union_cardinal: + forall s s', (forall x, ~(In x s/\In x s')) -> cardinal (union s s')=cardinal s+cardinal s'. Proof. intros; do 3 rewrite cardinal_fold. @@ -803,7 +802,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_union; auto. Qed. - Lemma subset_cardinal : + Lemma subset_cardinal : forall s s', s[<=]s' -> cardinal s <= cardinal s' . Proof. intros. @@ -812,9 +811,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). rewrite (inter_subset_equal H); auto with arith. Qed. - Lemma subset_cardinal_lt : + Lemma subset_cardinal_lt : forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'. - Proof. + Proof. intros. rewrite <- (diff_inter_cardinal s' s). rewrite (inter_sym s' s). @@ -826,7 +825,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). intros _. change (0 + cardinal s < S n + cardinal s). apply Plus.plus_lt_le_compat; auto with arith. - Qed. + Qed. Theorem union_inter_cardinal : forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . @@ -837,7 +836,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply fold_union_inter with (eqA:=@Logic.eq nat); auto. Qed. - Lemma union_cardinal_inter : + Lemma union_cardinal_inter : forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s'). Proof. intros. @@ -846,17 +845,17 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). auto with arith. Qed. - Lemma union_cardinal_le : + Lemma union_cardinal_le : forall s s', cardinal (union s s') <= cardinal s + cardinal s'. Proof. intros; generalize (union_inter_cardinal s s'). intros; rewrite <- H; auto with arith. Qed. - Lemma add_cardinal_1 : + Lemma add_cardinal_1 : forall s x, In x s -> cardinal (add x s) = cardinal s. Proof. - auto with set. + auto with set. Qed. Lemma add_cardinal_2 : @@ -877,9 +876,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply remove_fold_1 with (eqA:=@Logic.eq nat); auto. Qed. - Lemma remove_cardinal_2 : + Lemma remove_cardinal_2 : forall s x, ~In x s -> cardinal (remove x s) = cardinal s. - Proof. + Proof. auto with set. Qed. @@ -910,7 +909,7 @@ Module OrdProperties (M:S). Lemma sort_equivlistA_eqlistA : forall l l' : list elt, sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'. Proof. - apply SortA_equivlistA_eqlistA; eauto. + apply SortA_equivlistA_eqlistA; eauto with *. Qed. Definition gtb x y := match E.compare x y with GT _ => true | _ => false end. @@ -929,7 +928,7 @@ Module OrdProperties (M:S). intros; unfold leb, gtb; destruct (E.compare x y); intuition; try discriminate; ME.order. Qed. - Lemma gtb_compat : forall x, compat_bool E.eq (gtb x). + Lemma gtb_compat : forall x, Proper (E.eq==>Logic.eq) (gtb x). Proof. red; intros x a b H. generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto. @@ -943,89 +942,88 @@ Module OrdProperties (M:S). rewrite <- H1; auto. Qed. - Lemma leb_compat : forall x, compat_bool E.eq (leb x). + Lemma leb_compat : forall x, Proper (E.eq==>Logic.eq) (leb x). Proof. red; intros x a b H; unfold leb. f_equal; apply gtb_compat; auto. Qed. Hint Resolve gtb_compat leb_compat. - Lemma elements_split : forall x s, + Lemma elements_split : forall x s, elements s = elements_lt x s ++ elements_ge x s. Proof. unfold elements_lt, elements_ge, leb; intros. - eapply (@filter_split _ E.eq); eauto with set. ME.order. ME.order. ME.order. + eapply (@filter_split _ E.eq _ E.lt); auto with *. intros. rewrite gtb_1 in H. assert (~E.lt y x). - unfold gtb in *; destruct (E.compare x y); intuition; try discriminate; ME.order. + unfold gtb in *; destruct (E.compare x y); intuition; + try discriminate; ME.order. ME.order. Qed. - Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> - eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). + Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> + eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). Proof. intros; unfold elements_ge, elements_lt. apply sort_equivlistA_eqlistA; auto with set. - apply (@SortA_app _ E.eq); auto. - apply (@filter_sort _ E.eq); auto with set; eauto with set. + apply (@SortA_app _ E.eq); auto with *. + apply (@filter_sort _ E.eq); auto with *. constructor; auto. - apply (@filter_sort _ E.eq); auto with set; eauto with set. - rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with set). + apply (@filter_sort _ E.eq); auto with *. + rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with *). intros. - rewrite filter_InA in H1; auto; destruct H1. + rewrite filter_InA in H1; auto with *; destruct H1. rewrite leb_1 in H2. rewrite <- elements_iff in H1. assert (~E.eq x y). contradict H; rewrite H; auto. ME.order. intros. - rewrite filter_InA in H1; auto; destruct H1. + rewrite filter_InA in H1; auto with *; destruct H1. rewrite gtb_1 in H3. inversion_clear H2. ME.order. - rewrite filter_InA in H4; auto; destruct H4. + rewrite filter_InA in H4; auto with *; destruct H4. rewrite leb_1 in H4. ME.order. red; intros a. - rewrite InA_app_iff; rewrite InA_cons. - do 2 (rewrite filter_InA; auto). - do 2 rewrite <- elements_iff. - rewrite leb_1; rewrite gtb_1. - rewrite (H0 a); intuition. + rewrite InA_app_iff, InA_cons, !filter_InA, <-elements_iff, + leb_1, gtb_1, (H0 a) by auto with *. + intuition. destruct (E.compare a x); intuition. - right; right; split; auto. + right; right; split; auto with *. ME.order. Qed. Definition Above x s := forall y, In y s -> E.lt y x. Definition Below x s := forall y, In y s -> E.lt x y. - Lemma elements_Add_Above : forall s s' x, - Above x s -> Add x s s' -> + Lemma elements_Add_Above : forall s s' x, + Above x s -> Add x s s' -> eqlistA E.eq (elements s') (elements s ++ x::nil). Proof. intros. - apply sort_equivlistA_eqlistA; auto with set. - apply (@SortA_app _ E.eq); auto with set. + apply sort_equivlistA_eqlistA; auto with *. + apply (@SortA_app _ E.eq); auto with *. intros. inversion_clear H2. rewrite <- elements_iff in H1. apply ME.lt_eq with x; auto. inversion H3. red; intros a. - rewrite InA_app_iff; rewrite InA_cons; rewrite InA_nil. + rewrite InA_app_iff, InA_cons, InA_nil by auto with *. do 2 rewrite <- elements_iff; rewrite (H0 a); intuition. Qed. - Lemma elements_Add_Below : forall s s' x, - Below x s -> Add x s s' -> + Lemma elements_Add_Below : forall s s' x, + Below x s -> Add x s s' -> eqlistA E.eq (elements s') (x::elements s). Proof. intros. - apply sort_equivlistA_eqlistA; auto with set. + apply sort_equivlistA_eqlistA; auto with *. change (sort E.lt ((x::nil) ++ elements s)). - apply (@SortA_app _ E.eq); auto with set. + apply (@SortA_app _ E.eq); auto with *. intros. inversion_clear H1. rewrite <- elements_iff in H2. @@ -1036,7 +1034,7 @@ Module OrdProperties (M:S). do 2 rewrite <- elements_iff; rewrite (H0 a); intuition. Qed. - (** Two other induction principles on sets: we can be more restrictive + (** Two other induction principles on sets: we can be more restrictive on the element we add at each step. *) Lemma set_induction_max : @@ -1117,15 +1115,15 @@ Module OrdProperties (M:S). apply elements_Add_Below; auto. Qed. - (** The following results have already been proved earlier, + (** The following results have already been proved earlier, but we can now prove them with one hypothesis less: no need for [(transpose eqA f)]. *) - Section FoldOpt. + Section FoldOpt. Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f). - Lemma fold_equal : + Lemma fold_equal : forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). Proof. intros; do 2 rewrite M.fold_1. @@ -1136,13 +1134,13 @@ Module OrdProperties (M:S). red; intro a; do 2 rewrite <- elements_iff; auto. Qed. - Lemma add_fold : forall i s x, In x s -> + Lemma add_fold : forall i s x, In x s -> eqA (fold f (add x s) i) (fold f s i). Proof. intros; apply fold_equal; auto with set. Qed. - Lemma remove_fold_2: forall i s x, ~In x s -> + Lemma remove_fold_2: forall i s x, ~In x s -> eqA (fold f (remove x s) i) (fold f s i). Proof. intros. @@ -1153,16 +1151,16 @@ Module OrdProperties (M:S). (** An alternative version of [choose_3] *) - Lemma choose_equal : forall s s', Equal s s' -> - match choose s, choose s' with + Lemma choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with | Some x, Some x' => E.eq x x' | None, None => True | _, _ => False end. Proof. - intros s s' H; + intros s s' H; generalize (@choose_1 s)(@choose_2 s) - (@choose_1 s')(@choose_2 s')(@choose_3 s s'); + (@choose_1 s')(@choose_2 s')(@choose_3 s s'); destruct (choose s); destruct (choose s'); simpl; intuition. apply H5 with e; rewrite <-H; auto. apply H5 with e; rewrite H; auto. diff --git a/theories/FSets/FSetToFiniteSet.v b/theories/FSets/FSetToFiniteSet.v index 56a66261..01138270 100644 --- a/theories/FSets/FSetToFiniteSet.v +++ b/theories/FSets/FSetToFiniteSet.v @@ -6,24 +6,21 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre - * Institution: LRI, CNRS UMR 8623 - Université Paris Sud - * 91405 Orsay, France *) +(* $Id$ *) -(* $Id: FSetToFiniteSet.v 11735 2009-01-02 17:22:31Z herbelin $ *) +(** * Finite sets library : conversion to old [Finite_sets] *) Require Import Ensembles Finite_sets. Require Import FSetInterface FSetProperties OrderedTypeEx DecidableTypeEx. -(** * Going from [FSets] with usual Leibniz equality +(** * Going from [FSets] with usual Leibniz equality to the good old [Ensembles] and [Finite_sets] theory. *) Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). Module MP:= WProperties_fun U M. Import M MP FM Ensembles Finite_sets. - Definition mkEns : M.t -> Ensemble M.elt := + Definition mkEns : M.t -> Ensemble M.elt := fun s x => M.In x s. Notation " !! " := mkEns. @@ -115,11 +112,11 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). Proof. intro s; pattern s; apply set_induction; clear s; intros. intros; replace (!!s) with (Empty_set elt); auto with sets. - symmetry; apply Extensionality_Ensembles. + symmetry; apply Extensionality_Ensembles. apply Empty_Empty_set; auto. replace (!!s') with (Add _ (!!s) x). constructor 2; auto. - symmetry; apply Extensionality_Ensembles. + symmetry; apply Extensionality_Ensembles. apply Add_Add; auto. Qed. @@ -128,18 +125,18 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). intro s; pattern s; apply set_induction; clear s; intros. intros; replace (!!s) with (Empty_set elt); auto with sets. rewrite cardinal_1; auto with sets. - symmetry; apply Extensionality_Ensembles. + symmetry; apply Extensionality_Ensembles. apply Empty_Empty_set; auto. replace (!!s') with (Add _ (!!s) x). - rewrite (cardinal_2 H0 H1); auto with sets. - symmetry; apply Extensionality_Ensembles. + rewrite (cardinal_2 H0 H1); auto with sets. + symmetry; apply Extensionality_Ensembles. apply Add_Add; auto. Qed. - (** we can even build a function from Finite Ensemble to FSet + (** we can even build a function from Finite Ensemble to FSet ... at least in Prop. *) - Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> + Lemma Ens_to_FSet : forall e : Ensemble M.elt, Finite _ e -> exists s:M.t, !!s === e. Proof. induction 1. @@ -147,7 +144,7 @@ Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). apply empty_Empty_Set. destruct IHFinite as (s,Hs). exists (M.add x s). - apply Extensionality_Ensembles in Hs. + apply Extensionality_Ensembles in Hs. rewrite <- Hs. apply add_Add. Qed. diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v index 309016ce..711cbd9a 100644 --- a/theories/FSets/FSetWeakList.v +++ b/theories/FSets/FSetWeakList.v @@ -6,952 +6,25 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSetWeakList.v 11866 2009-01-28 19:10:15Z letouzey $ *) +(* $Id$ *) (** * Finite sets library *) -(** This file proposes an implementation of the non-dependant - interface [FSetWeakInterface.S] using lists without redundancy. *) +(** This file proposes an implementation of the non-dependant + interface [FSetInterface.WS] using lists without redundancy. *) Require Import FSetInterface. Set Implicit Arguments. Unset Strict Implicit. -(** * Functions over lists +(** This is just a compatibility layer, the real implementation + is now in [MSetWeakList] *) - First, we provide sets as lists which are (morally) without redundancy. - The specs are proved under the additional condition of no redundancy. - And the functions returning sets are proved to preserve this invariant. *) - -Module Raw (X: DecidableType). - - Definition elt := X.t. - Definition t := list elt. - - Definition empty : t := nil. - - Definition is_empty (l : t) : bool := if l then true else false. - - (** ** The set operations. *) - - Fixpoint mem (x : elt) (s : t) {struct s} : bool := - match s with - | nil => false - | y :: l => - if X.eq_dec x y then true else mem x l - end. - - Fixpoint add (x : elt) (s : t) {struct s} : t := - match s with - | nil => x :: nil - | y :: l => - if X.eq_dec x y then s else y :: add x l - end. - - Definition singleton (x : elt) : t := x :: nil. - - Fixpoint remove (x : elt) (s : t) {struct s} : t := - match s with - | nil => nil - | y :: l => - if X.eq_dec x y then l else y :: remove x l - end. - - Fixpoint fold (B : Type) (f : elt -> B -> B) (s : t) {struct s} : - B -> B := fun i => match s with - | nil => i - | x :: l => fold f l (f x i) - end. - - Definition union (s : t) : t -> t := fold add s. - - Definition diff (s s' : t) : t := fold remove s' s. - - Definition inter (s s': t) : t := - fold (fun x s => if mem x s' then add x s else s) s nil. - - Definition subset (s s' : t) : bool := is_empty (diff s s'). - - Definition equal (s s' : t) : bool := andb (subset s s') (subset s' s). - - Fixpoint filter (f : elt -> bool) (s : t) {struct s} : t := - match s with - | nil => nil - | x :: l => if f x then x :: filter f l else filter f l - end. - - Fixpoint for_all (f : elt -> bool) (s : t) {struct s} : bool := - match s with - | nil => true - | x :: l => if f x then for_all f l else false - end. - - Fixpoint exists_ (f : elt -> bool) (s : t) {struct s} : bool := - match s with - | nil => false - | x :: l => if f x then true else exists_ f l - end. - - Fixpoint partition (f : elt -> bool) (s : t) {struct s} : - t * t := - match s with - | nil => (nil, nil) - | x :: l => - let (s1, s2) := partition f l in - if f x then (x :: s1, s2) else (s1, x :: s2) - end. - - Definition cardinal (s : t) : nat := length s. - - Definition elements (s : t) : list elt := s. - - Definition choose (s : t) : option elt := - match s with - | nil => None - | x::_ => Some x - end. - - (** ** Proofs of set operation specifications. *) - Section ForNotations. - Notation NoDup := (NoDupA X.eq). - Notation In := (InA X.eq). - - Definition Equal s s' := forall a : elt, In a s <-> In a s'. - Definition Subset s s' := forall a : elt, In a s -> In a s'. - Definition Empty s := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. - Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. - - Lemma In_eq : - forall (s : t) (x y : elt), X.eq x y -> In x s -> In y s. - Proof. - intros s x y; setoid_rewrite InA_alt; firstorder eauto. - Qed. - Hint Immediate In_eq. - - Lemma mem_1 : - forall (s : t)(x : elt), In x s -> mem x s = true. - Proof. - induction s; intros. - inversion H. - simpl; destruct (X.eq_dec x a); trivial. - inversion_clear H; auto. - Qed. - - Lemma mem_2 : forall (s : t) (x : elt), mem x s = true -> In x s. - Proof. - induction s. - intros; inversion H. - intros x; simpl. - destruct (X.eq_dec x a); firstorder; discriminate. - Qed. - - Lemma add_1 : - forall (s : t) (Hs : NoDup s) (x y : elt), X.eq x y -> In y (add x s). - Proof. - induction s. - simpl; intuition. - simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs; - firstorder. - eauto. - Qed. - - Lemma add_2 : - forall (s : t) (Hs : NoDup s) (x y : elt), In y s -> In y (add x s). - Proof. - induction s. - simpl; intuition. - simpl; intros; case (X.eq_dec x a); intuition. - inversion_clear Hs; eauto; inversion_clear H; intuition. - Qed. - - Lemma add_3 : - forall (s : t) (Hs : NoDup s) (x y : elt), - ~ X.eq x y -> In y (add x s) -> In y s. - Proof. - induction s. - simpl; intuition. - inversion_clear H0; firstorder; absurd (X.eq x y); auto. - simpl; intros Hs x y; case (X.eq_dec x a); intros; - inversion_clear H0; inversion_clear Hs; firstorder; - absurd (X.eq x y); auto. - Qed. - - Lemma add_unique : - forall (s : t) (Hs : NoDup s)(x:elt), NoDup (add x s). - Proof. - induction s. - simpl; intuition. - constructor; auto. - intro H0; inversion H0. - intros. - inversion_clear Hs. - simpl. - destruct (X.eq_dec x a). - constructor; auto. - constructor; auto. - intro H1; apply H. - eapply add_3; eauto. - Qed. - - Lemma remove_1 : - forall (s : t) (Hs : NoDup s) (x y : elt), X.eq x y -> ~ In y (remove x s). - Proof. - simple induction s. - simpl; red; intros; inversion H0. - simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs. - elim H2. - apply In_eq with y; eauto. - inversion_clear H1; eauto. - Qed. - - Lemma remove_2 : - forall (s : t) (Hs : NoDup s) (x y : elt), - ~ X.eq x y -> In y s -> In y (remove x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs; - inversion_clear H1; auto. - absurd (X.eq x y); eauto. - Qed. - - Lemma remove_3 : - forall (s : t) (Hs : NoDup s) (x y : elt), In y (remove x s) -> In y s. - Proof. - simple induction s. - simpl; intuition. - simpl; intros a l Hrec Hs x y; case (X.eq_dec x a); intuition. - inversion_clear Hs; inversion_clear H; firstorder. - Qed. - - Lemma remove_unique : - forall (s : t) (Hs : NoDup s) (x : elt), NoDup (remove x s). - Proof. - simple induction s. - simpl; intuition. - simpl; intros; case (X.eq_dec x a); intuition; inversion_clear Hs; - auto. - constructor; auto. - intro H2; elim H0. - eapply remove_3; eauto. - Qed. - - Lemma singleton_unique : forall x : elt, NoDup (singleton x). - Proof. - unfold singleton; simpl; constructor; auto; intro H; inversion H. - Qed. - - Lemma singleton_1 : forall x y : elt, In y (singleton x) -> X.eq x y. - Proof. - unfold singleton; simpl; intuition. - inversion_clear H; auto; inversion H0. - Qed. - - Lemma singleton_2 : forall x y : elt, X.eq x y -> In y (singleton x). - Proof. - unfold singleton; simpl; intuition. - Qed. - - Lemma empty_unique : NoDup empty. - Proof. - unfold empty; constructor. - Qed. - - Lemma empty_1 : Empty empty. - Proof. - unfold Empty, empty; intuition; inversion H. - Qed. - - Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true. - Proof. - unfold Empty; intro s; case s; simpl; intuition. - elim (H e); auto. - Qed. - - Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. - Proof. - unfold Empty; intro s; case s; simpl; intuition; - inversion H0. - Qed. - - Lemma elements_1 : forall (s : t) (x : elt), In x s -> In x (elements s). - Proof. - unfold elements; auto. - Qed. - - Lemma elements_2 : forall (s : t) (x : elt), In x (elements s) -> In x s. - Proof. - unfold elements; auto. - Qed. - - Lemma elements_3w : forall (s : t) (Hs : NoDup s), NoDup (elements s). - Proof. - unfold elements; auto. - Qed. - - Lemma fold_1 : - forall (s : t) (Hs : NoDup s) (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. - induction s; simpl; auto; intros. - inversion_clear Hs; auto. - Qed. - - Lemma union_unique : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (union s s'). - Proof. - unfold union; induction s; simpl; auto; intros. - inversion_clear Hs. - apply IHs; auto. - apply add_unique; auto. - Qed. - - Lemma union_1 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (union s s') -> In x s \/ In x s'. - Proof. - unfold union; induction s; simpl; auto; intros. - inversion_clear Hs. - destruct (X.eq_dec x a). - left; auto. - destruct (IHs (add a s') H1 (add_unique Hs' a) x); intuition. - right; eapply add_3; eauto. - Qed. - - Lemma union_0 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x s \/ In x s' -> In x (union s s'). - Proof. - unfold union; induction s; simpl; auto; intros. - inversion_clear H; auto. - inversion_clear H0. - inversion_clear Hs. - apply IHs; auto. - apply add_unique; auto. - destruct H. - inversion_clear H; auto. - right; apply add_1; auto. - right; apply add_2; auto. - Qed. - - Lemma union_2 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x s -> In x (union s s'). - Proof. - intros; apply union_0; auto. - Qed. - - Lemma union_3 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x s' -> In x (union s s'). - Proof. - intros; apply union_0; auto. - Qed. - - Lemma inter_unique : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (inter s s'). - Proof. - unfold inter; intros s. - set (acc := nil (A:=elt)). - assert (NoDup acc) by (unfold acc; auto). - clearbody acc; generalize H; clear H; generalize acc; clear acc. - induction s; simpl; auto; intros. - inversion_clear Hs. - apply IHs; auto. - destruct (mem a s'); intros; auto. - apply add_unique; auto. - Qed. - - Lemma inter_0 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (inter s s') -> In x s /\ In x s'. - Proof. - unfold inter; intros. - set (acc := nil (A:=elt)) in *. - assert (NoDup acc) by (unfold acc; auto). - cut ((In x s /\ In x s') \/ In x acc). - destruct 1; auto. - inversion H1. - clearbody acc. - generalize H0 H Hs' Hs; clear H0 H Hs Hs'. - generalize acc x s'; clear acc x s'. - induction s; simpl; auto; intros. - inversion_clear Hs. - case_eq (mem a s'); intros H3; rewrite H3 in H; simpl in H. - destruct (IHs _ _ _ (add_unique H0 a) H); auto. - left; intuition. - destruct (X.eq_dec x a); auto. - left; intuition. - apply In_eq with a; eauto. - apply mem_2; auto. - right; eapply add_3; eauto. - destruct (IHs _ _ _ H0 H); auto. - left; intuition. - Qed. - - Lemma inter_1 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (inter s s') -> In x s. - Proof. - intros; cut (In x s /\ In x s'); [ intuition | apply inter_0; auto ]. - Qed. - - Lemma inter_2 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (inter s s') -> In x s'. - Proof. - intros; cut (In x s /\ In x s'); [ intuition | apply inter_0; auto ]. - Qed. - - Lemma inter_3 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x s -> In x s' -> In x (inter s s'). - Proof. - intros s s' Hs Hs' x. - cut (((In x s /\ In x s')\/ In x (nil (A:=elt))) -> In x (inter s s')). - intuition. - unfold inter. - set (acc := nil (A:=elt)) in *. - assert (NoDup acc) by (unfold acc; auto). - clearbody acc. - generalize H Hs' Hs; clear H Hs Hs'. - generalize acc x s'; clear acc x s'. - induction s; simpl; auto; intros. - destruct H0; auto. - destruct H0; inversion H0. - inversion_clear Hs. - case_eq (mem a s'); intros H3; apply IHs; auto. - apply add_unique; auto. - destruct H0. - destruct H0. - inversion_clear H0. - right; apply add_1; auto. - left; auto. - right; apply add_2; auto. - destruct H0; auto. - destruct H0. - inversion_clear H0; auto. - absurd (In x s'); auto. - red; intros. - rewrite (mem_1 (In_eq H5 H0)) in H3. - discriminate. - Qed. - - Lemma diff_unique : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), NoDup (diff s s'). - Proof. - unfold diff; intros s s' Hs; generalize s Hs; clear Hs s. - induction s'; simpl; auto; intros. - inversion_clear Hs'. - apply IHs'; auto. - apply remove_unique; auto. - Qed. - - Lemma diff_0 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (diff s s') -> In x s /\ ~ In x s'. - Proof. - unfold diff; intros s s' Hs; generalize s Hs; clear Hs s. - induction s'; simpl; auto; intros. - inversion_clear Hs'. - split; auto; intro H1; inversion H1. - inversion_clear Hs'. - destruct (IHs' (remove a s) (remove_unique Hs a) H1 x H). - split. - eapply remove_3; eauto. - red; intros. - inversion_clear H4; auto. - destruct (remove_1 Hs (X.eq_sym H5) H2). - Qed. - - Lemma diff_1 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (diff s s') -> In x s. - Proof. - intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. - Qed. - - Lemma diff_2 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x (diff s s') -> ~ In x s'. - Proof. - intros; cut (In x s /\ ~ In x s'); [ intuition | apply diff_0; auto]. - Qed. - - Lemma diff_3 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s') (x : elt), - In x s -> ~ In x s' -> In x (diff s s'). - Proof. - unfold diff; intros s s' Hs; generalize s Hs; clear Hs s. - induction s'; simpl; auto; intros. - inversion_clear Hs'. - apply IHs'; auto. - apply remove_unique; auto. - apply remove_2; auto. - Qed. - - Lemma subset_1 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), - Subset s s' -> subset s s' = true. - Proof. - unfold subset, Subset; intros. - apply is_empty_1. - unfold Empty; intros. - intro. - destruct (diff_2 Hs Hs' H0). - apply H. - eapply diff_1; eauto. - Qed. - - Lemma subset_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'), - subset s s' = true -> Subset s s'. - Proof. - unfold subset, Subset; intros. - generalize (is_empty_2 H); clear H; unfold Empty; intros. - generalize (@mem_1 s' a) (@mem_2 s' a); destruct (mem a s'). - intuition. - intros. - destruct (H a). - apply diff_3; intuition. - Qed. - - Lemma equal_1 : - forall (s s' : t) (Hs : NoDup s) (Hs' : NoDup s'), - Equal s s' -> equal s s' = true. - Proof. - unfold Equal, equal; intros. - apply andb_true_intro; split; apply subset_1; firstorder. - Qed. - - Lemma equal_2 : forall (s s' : t)(Hs : NoDup s) (Hs' : NoDup s'), - equal s s' = true -> Equal s s'. - Proof. - unfold Equal, equal; intros. - destruct (andb_prop _ _ H); clear H. - split; apply subset_2; auto. - Qed. - - Definition choose_1 : - forall (s : t) (x : elt), choose s = Some x -> In x s. - Proof. - destruct s; simpl; intros; inversion H; auto. - Qed. - - Definition choose_2 : forall s : t, choose s = None -> Empty s. - Proof. - destruct s; simpl; intros. - intros x H0; inversion H0. - inversion H. - Qed. - - Lemma cardinal_1 : - forall (s : t) (Hs : NoDup s), cardinal s = length (elements s). - Proof. - auto. - Qed. - - Lemma filter_1 : - forall (s : t) (x : elt) (f : elt -> bool), - In x (filter f s) -> In x s. - Proof. - simple induction s; simpl. - intros; inversion H. - intros x l Hrec a f. - case (f x); simpl. - inversion_clear 1. - constructor; auto. - constructor 2; apply (Hrec a f); trivial. - constructor 2; apply (Hrec a f); trivial. - Qed. - - Lemma filter_2 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x (filter f s) -> f x = true. - Proof. - simple induction s; simpl. - intros; inversion H0. - intros x l Hrec a f Hf. - generalize (Hf x); case (f x); simpl; auto. - inversion_clear 2; auto. - symmetry; auto. - Qed. - - Lemma filter_3 : - forall (s : t) (x : elt) (f : elt -> bool), - compat_bool X.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. - simple induction s; simpl. - intros; inversion H0. - intros x l Hrec a f Hf. - generalize (Hf x); case (f x); simpl. - inversion_clear 2; auto. - inversion_clear 2; auto. - rewrite <- (H a (X.eq_sym H1)); intros; discriminate. - Qed. - - Lemma filter_unique : - forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (filter f s). - Proof. - simple induction s; simpl. - auto. - intros x l Hrec Hs f; inversion_clear Hs. - case (f x); auto. - constructor; auto. - intro H1; apply H. - eapply filter_1; eauto. - Qed. - - - Lemma for_all_1 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Proof. - simple induction s; simpl; auto; unfold For_all. - intros x l Hrec f Hf. - generalize (Hf x); case (f x); simpl. - auto. - intros; rewrite (H x); auto. - Qed. - - Lemma for_all_2 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - Proof. - simple induction s; simpl; auto; unfold For_all. - intros; inversion H1. - intros x l Hrec f Hf. - intros A a; intros. - assert (f x = true). - generalize A; case (f x); auto. - rewrite H0 in A; simpl in A. - inversion_clear H; auto. - rewrite (Hf a x); auto. - Qed. - - Lemma exists_1 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. - simple induction s; simpl; auto; unfold Exists. - intros. - elim H0; intuition. - inversion H2. - intros x l Hrec f Hf. - generalize (Hf x); case (f x); simpl. - auto. - destruct 2 as [a (A1,A2)]. - inversion_clear A1. - rewrite <- (H a (X.eq_sym H0)) in A2; discriminate. - apply Hrec; auto. - exists a; auto. - Qed. - - Lemma exists_2 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. - simple induction s; simpl; auto; unfold Exists. - intros; discriminate. - intros x l Hrec f Hf. - case_eq (f x); intros. - exists x; auto. - destruct (Hrec f Hf H0) as [a (A1,A2)]. - exists a; auto. - Qed. - - Lemma partition_1 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> Equal (fst (partition f s)) (filter f s). - Proof. - simple induction s; simpl; auto; unfold Equal. - firstorder. - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - case (partition f l); intros s1 s2; simpl; intros. - case (f x); simpl; firstorder; inversion H0; intros; firstorder. - Qed. - - Lemma partition_2 : - forall (s : t) (f : elt -> bool), - compat_bool X.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. - simple induction s; simpl; auto; unfold Equal. - firstorder. - intros x l Hrec f Hf. - generalize (Hrec f Hf); clear Hrec. - case (partition f l); intros s1 s2; simpl; intros. - case (f x); simpl; firstorder; inversion H0; intros; firstorder. - Qed. - - Lemma partition_aux_1 : - forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), - In x (fst (partition f s)) -> In x s. - Proof. - induction s; simpl; auto; intros. - inversion_clear Hs. - generalize (IHs H1 f x). - destruct (f a); destruct (partition f s); simpl in *; auto. - inversion_clear H; auto. - Qed. - - Lemma partition_aux_2 : - forall (s : t) (Hs : NoDup s) (f : elt -> bool)(x:elt), - In x (snd (partition f s)) -> In x s. - Proof. - induction s; simpl; auto; intros. - inversion_clear Hs. - generalize (IHs H1 f x). - destruct (f a); destruct (partition f s); simpl in *; auto. - inversion_clear H; auto. - Qed. - - Lemma partition_unique_1 : - forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (fst (partition f s)). - Proof. - simple induction s; simpl. - auto. - intros x l Hrec Hs f; inversion_clear Hs. - generalize (@partition_aux_1 _ H0 f x). - generalize (Hrec H0 f). - case (f x); case (partition f l); simpl; auto. - Qed. - - Lemma partition_unique_2 : - forall (s : t) (Hs : NoDup s) (f : elt -> bool), NoDup (snd (partition f s)). - Proof. - simple induction s; simpl. - auto. - intros x l Hrec Hs f; inversion_clear Hs. - generalize (@partition_aux_2 _ H0 f x). - generalize (Hrec H0 f). - case (f x); case (partition f l); simpl; auto. - Qed. - - Definition eq : t -> t -> Prop := Equal. - - Lemma eq_refl : forall s, eq s s. - Proof. firstorder. Qed. - - Lemma eq_sym : forall s s', eq s s' -> eq s' s. - Proof. firstorder. Qed. - - Lemma eq_trans : - forall s s' s'', eq s s' -> eq s' s'' -> eq s s''. - Proof. firstorder. Qed. - - Definition eq_dec : forall (s s':t)(Hs:NoDup s)(Hs':NoDup s'), - { eq s s' }+{ ~eq s s' }. - Proof. - intros. - change eq with Equal. - case_eq (equal s s'); intro H; [left | right]. - apply equal_2; auto. - intro H'; rewrite equal_1 in H; auto; discriminate. - Defined. - - End ForNotations. -End Raw. - -(** * Encapsulation - - Now, in order to really provide a functor implementing [S], we - need to encapsulate everything into a type of lists without redundancy. *) +Require Equalities FSetCompat MSetWeakList. Module Make (X: DecidableType) <: WS with Module E := X. - - Module Raw := Raw X. Module E := X. - - Record slist := {this :> Raw.t; unique : NoDupA E.eq this}. - Definition t := slist. - Definition elt := E.t. - - Definition In (x : elt) (s : t) : Prop := InA E.eq x s.(this). - Definition Equal (s s':t) : Prop := forall a : elt, In a s <-> In a s'. - Definition Subset (s s':t) : Prop := forall a : elt, In a s -> In a s'. - Definition Empty (s:t) : Prop := forall a : elt, ~ In a s. - Definition For_all (P : elt -> Prop) (s : t) : Prop := - forall x : elt, In x s -> P x. - Definition Exists (P : elt -> Prop) (s : t) : Prop := exists x : elt, In x s /\ P x. - - Definition mem (x : elt) (s : t) : bool := Raw.mem x s. - Definition add (x : elt)(s : t) : t := Build_slist (Raw.add_unique (unique s) x). - Definition remove (x : elt)(s : t) : t := Build_slist (Raw.remove_unique (unique s) x). - Definition singleton (x : elt) : t := Build_slist (Raw.singleton_unique x). - Definition union (s s' : t) : t := - Build_slist (Raw.union_unique (unique s) (unique s')). - Definition inter (s s' : t) : t := - Build_slist (Raw.inter_unique (unique s) (unique s')). - Definition diff (s s' : t) : t := - Build_slist (Raw.diff_unique (unique s) (unique s')). - Definition equal (s s' : t) : bool := Raw.equal s s'. - Definition subset (s s' : t) : bool := Raw.subset s s'. - Definition empty : t := Build_slist Raw.empty_unique. - Definition is_empty (s : t) : bool := Raw.is_empty s. - Definition elements (s : t) : list elt := Raw.elements s. - Definition choose (s:t) : option elt := Raw.choose s. - Definition fold (B : Type) (f : elt -> B -> B) (s : t) : B -> B := Raw.fold (B:=B) f s. - Definition cardinal (s : t) : nat := Raw.cardinal s. - Definition filter (f : elt -> bool) (s : t) : t := - Build_slist (Raw.filter_unique (unique s) f). - Definition for_all (f : elt -> bool) (s : t) : bool := Raw.for_all f s. - Definition exists_ (f : elt -> bool) (s : t) : bool := Raw.exists_ f s. - Definition partition (f : elt -> bool) (s : t) : t * t := - let p := Raw.partition f s in - (Build_slist (this:=fst p) (Raw.partition_unique_1 (unique s) f), - Build_slist (this:=snd p) (Raw.partition_unique_2 (unique s) f)). - - Section Spec. - Variable s s' : t. - Variable x y : elt. - - Lemma In_1 : E.eq x y -> In x s -> In y s. - Proof. exact (fun H H' => Raw.In_eq H H'). Qed. - - Lemma mem_1 : In x s -> mem x s = true. - Proof. exact (fun H => Raw.mem_1 H). Qed. - Lemma mem_2 : mem x s = true -> In x s. - Proof. exact (fun H => Raw.mem_2 H). Qed. - - Lemma equal_1 : Equal s s' -> equal s s' = true. - Proof. exact (Raw.equal_1 s.(unique) s'.(unique)). Qed. - Lemma equal_2 : equal s s' = true -> Equal s s'. - Proof. exact (Raw.equal_2 s.(unique) s'.(unique)). Qed. - - Lemma subset_1 : Subset s s' -> subset s s' = true. - Proof. exact (Raw.subset_1 s.(unique) s'.(unique)). Qed. - Lemma subset_2 : subset s s' = true -> Subset s s'. - Proof. exact (Raw.subset_2 s.(unique) s'.(unique)). Qed. - - Lemma empty_1 : Empty empty. - Proof. exact Raw.empty_1. Qed. - - Lemma is_empty_1 : Empty s -> is_empty s = true. - Proof. exact (fun H => Raw.is_empty_1 H). Qed. - Lemma is_empty_2 : is_empty s = true -> Empty s. - Proof. exact (fun H => Raw.is_empty_2 H). Qed. - - Lemma add_1 : E.eq x y -> In y (add x s). - Proof. exact (fun H => Raw.add_1 s.(unique) H). Qed. - Lemma add_2 : In y s -> In y (add x s). - Proof. exact (fun H => Raw.add_2 s.(unique) x H). Qed. - Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. - Proof. exact (fun H => Raw.add_3 s.(unique) H). Qed. - - Lemma remove_1 : E.eq x y -> ~ In y (remove x s). - Proof. exact (fun H => Raw.remove_1 s.(unique) H). Qed. - Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). - Proof. exact (fun H H' => Raw.remove_2 s.(unique) H H'). Qed. - Lemma remove_3 : In y (remove x s) -> In y s. - Proof. exact (fun H => Raw.remove_3 s.(unique) H). Qed. - - Lemma singleton_1 : In y (singleton x) -> E.eq x y. - Proof. exact (fun H => Raw.singleton_1 H). Qed. - Lemma singleton_2 : E.eq x y -> In y (singleton x). - Proof. exact (fun H => Raw.singleton_2 H). Qed. - - Lemma union_1 : In x (union s s') -> In x s \/ In x s'. - Proof. exact (fun H => Raw.union_1 s.(unique) s'.(unique) H). Qed. - Lemma union_2 : In x s -> In x (union s s'). - Proof. exact (fun H => Raw.union_2 s.(unique) s'.(unique) H). Qed. - Lemma union_3 : In x s' -> In x (union s s'). - Proof. exact (fun H => Raw.union_3 s.(unique) s'.(unique) H). Qed. - - Lemma inter_1 : In x (inter s s') -> In x s. - Proof. exact (fun H => Raw.inter_1 s.(unique) s'.(unique) H). Qed. - Lemma inter_2 : In x (inter s s') -> In x s'. - Proof. exact (fun H => Raw.inter_2 s.(unique) s'.(unique) H). Qed. - Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). - Proof. exact (fun H => Raw.inter_3 s.(unique) s'.(unique) H). Qed. - - Lemma diff_1 : In x (diff s s') -> In x s. - Proof. exact (fun H => Raw.diff_1 s.(unique) s'.(unique) H). Qed. - Lemma diff_2 : In x (diff s s') -> ~ In x s'. - Proof. exact (fun H => Raw.diff_2 s.(unique) s'.(unique) H). Qed. - Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). - Proof. exact (fun H => Raw.diff_3 s.(unique) s'.(unique) H). Qed. - - Lemma fold_1 : forall (A : Type) (i : A) (f : elt -> A -> A), - fold f s i = fold_left (fun a e => f e a) (elements s) i. - Proof. exact (Raw.fold_1 s.(unique)). Qed. - - Lemma cardinal_1 : cardinal s = length (elements s). - Proof. exact (Raw.cardinal_1 s.(unique)). Qed. - - Section Filter. - - Variable f : elt -> bool. - - Lemma filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. - Proof. exact (fun H => @Raw.filter_1 s x f). Qed. - Lemma filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. - Proof. exact (@Raw.filter_2 s x f). Qed. - Lemma filter_3 : - compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). - Proof. exact (@Raw.filter_3 s x f). Qed. - - Lemma for_all_1 : - compat_bool E.eq f -> - For_all (fun x => f x = true) s -> for_all f s = true. - Proof. exact (@Raw.for_all_1 s f). Qed. - Lemma for_all_2 : - compat_bool E.eq f -> - for_all f s = true -> For_all (fun x => f x = true) s. - Proof. exact (@Raw.for_all_2 s f). Qed. - - Lemma exists_1 : - compat_bool E.eq f -> - Exists (fun x => f x = true) s -> exists_ f s = true. - Proof. exact (@Raw.exists_1 s f). Qed. - Lemma exists_2 : - compat_bool E.eq f -> - exists_ f s = true -> Exists (fun x => f x = true) s. - Proof. exact (@Raw.exists_2 s f). Qed. - - Lemma partition_1 : - compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). - Proof. exact (@Raw.partition_1 s f). Qed. - Lemma partition_2 : - compat_bool E.eq f -> - Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). - Proof. exact (@Raw.partition_2 s f). Qed. - - End Filter. - - Lemma elements_1 : In x s -> InA E.eq x (elements s). - Proof. exact (fun H => Raw.elements_1 H). Qed. - Lemma elements_2 : InA E.eq x (elements s) -> In x s. - Proof. exact (fun H => Raw.elements_2 H). Qed. - Lemma elements_3w : NoDupA E.eq (elements s). - Proof. exact (Raw.elements_3w s.(unique)). Qed. - - Lemma choose_1 : choose s = Some x -> In x s. - Proof. exact (fun H => Raw.choose_1 H). Qed. - Lemma choose_2 : choose s = None -> Empty s. - Proof. exact (fun H => Raw.choose_2 H). Qed. - - End Spec. - - Definition eq : t -> t -> Prop := Equal. - - Lemma eq_refl : forall s, eq s s. - Proof. firstorder. Qed. - - Lemma eq_sym : forall s s', eq s s' -> eq s' s. - Proof. firstorder. Qed. - - Lemma eq_trans : - forall s s' s'', eq s s' -> eq s' s'' -> eq s s''. - Proof. firstorder. Qed. - - Definition eq_dec : forall (s s':t), - { eq s s' }+{ ~eq s s' }. - Proof. - intros s s'; exact (Raw.eq_dec s.(unique) s'.(unique)). - Defined. - + Module X' := Equalities.Update_DT X. + Module MSet := MSetWeakList.Make X'. + Include FSetCompat.Backport_WSets X MSet. End Make. diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v index a73c1da7..62a95734 100644 --- a/theories/FSets/FSets.v +++ b/theories/FSets/FSets.v @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) -(* $Id: FSets.v 10699 2008-03-19 20:56:43Z letouzey $ *) +(* $Id$ *) Require Export OrderedType. Require Export OrderedTypeEx. @@ -21,4 +21,5 @@ Require Export FSetProperties. Require Export FSetEqProperties. Require Export FSetWeakList. Require Export FSetList. +Require Export FSetPositive. Require Export FSetAVL.
\ No newline at end of file diff --git a/theories/FSets/OrderedType.v b/theories/FSets/OrderedType.v deleted file mode 100644 index fadd27dd..00000000 --- a/theories/FSets/OrderedType.v +++ /dev/null @@ -1,587 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* $Id: OrderedType.v 11700 2008-12-18 11:49:10Z letouzey $ *) - -Require Export SetoidList. -Set Implicit Arguments. -Unset Strict Implicit. - -(** * Ordered types *) - -Inductive Compare (X : Type) (lt eq : X -> X -> Prop) (x y : X) : Type := - | LT : lt x y -> Compare lt eq x y - | EQ : eq x y -> Compare lt eq x y - | GT : lt y x -> Compare lt eq x y. - -Module Type MiniOrderedType. - - Parameter Inline t : Type. - - Parameter Inline eq : t -> t -> Prop. - Parameter Inline lt : t -> t -> Prop. - - Axiom eq_refl : forall x : t, eq x x. - Axiom eq_sym : forall x y : t, eq x y -> eq y x. - Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - - Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - - Parameter compare : forall x y : t, Compare lt eq x y. - - Hint Immediate eq_sym. - Hint Resolve eq_refl eq_trans lt_not_eq lt_trans. - -End MiniOrderedType. - -Module Type OrderedType. - Include Type MiniOrderedType. - - (** A [eq_dec] can be deduced from [compare] below. But adding this - redundant field allows to see an OrderedType as a DecidableType. *) - Parameter eq_dec : forall x y, { eq x y } + { ~ eq x y }. - -End OrderedType. - -Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. - Include O. - - Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. - Proof. - intros; elim (compare x y); intro H; [ right | left | right ]; auto. - assert (~ eq y x); auto. - Defined. - -End MOT_to_OT. - -(** * Ordered types properties *) - -(** Additional properties that can be derived from signature - [OrderedType]. *) - -Module OrderedTypeFacts (Import O: OrderedType). - - Lemma lt_antirefl : forall x, ~ lt x x. - Proof. - intros; intro; absurd (eq x x); auto. - Qed. - - Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. - Proof. - intros; destruct (compare x z); auto. - elim (lt_not_eq H); apply eq_trans with z; auto. - elim (lt_not_eq (lt_trans l H)); auto. - Qed. - - Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. - Proof. - intros; destruct (compare x z); auto. - elim (lt_not_eq H0); apply eq_trans with x; auto. - elim (lt_not_eq (lt_trans H0 l)); auto. - Qed. - - Lemma le_eq : forall x y z, ~lt x y -> eq y z -> ~lt x z. - Proof. - intros; intro; destruct H; apply lt_eq with z; auto. - Qed. - - Lemma eq_le : forall x y z, eq x y -> ~lt y z -> ~lt x z. - Proof. - intros; intro; destruct H0; apply eq_lt with x; auto. - Qed. - - Lemma neq_eq : forall x y z, ~eq x y -> eq y z -> ~eq x z. - Proof. - intros; intro; destruct H; apply eq_trans with z; auto. - Qed. - - Lemma eq_neq : forall x y z, eq x y -> ~eq y z -> ~eq x z. - Proof. - intros; intro; destruct H0; apply eq_trans with x; auto. - Qed. - - Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq. - - Lemma le_lt_trans : forall x y z, ~lt y x -> lt y z -> lt x z. - Proof. - intros; destruct (compare y x); auto. - elim (H l). - apply eq_lt with y; auto. - apply lt_trans with y; auto. - Qed. - - Lemma lt_le_trans : forall x y z, lt x y -> ~lt z y -> lt x z. - Proof. - intros; destruct (compare z y); auto. - elim (H0 l). - apply lt_eq with y; auto. - apply lt_trans with y; auto. - Qed. - - Lemma le_neq : forall x y, ~lt x y -> ~eq x y -> lt y x. - Proof. - intros; destruct (compare x y); intuition. - Qed. - - Lemma neq_sym : forall x y, ~eq x y -> ~eq y x. - Proof. - intuition. - Qed. - -(* TODO concernant la tactique order: - * propagate_lt n'est sans doute pas complet - * un propagate_le - * exploiter les hypotheses negatives restant a la fin - * faire que ca marche meme quand une hypothese depend d'un eq ou lt. -*) - -Ltac abstraction := match goal with - (* First, some obvious simplifications *) - | H : False |- _ => elim H - | H : lt ?x ?x |- _ => elim (lt_antirefl H) - | H : ~eq ?x ?x |- _ => elim (H (eq_refl x)) - | H : eq ?x ?x |- _ => clear H; abstraction - | H : ~lt ?x ?x |- _ => clear H; abstraction - | |- eq ?x ?x => exact (eq_refl x) - | |- lt ?x ?x => elimtype False; abstraction - | |- ~ _ => intro; abstraction - | H1: ~lt ?x ?y, H2: ~eq ?x ?y |- _ => - generalize (le_neq H1 H2); clear H1 H2; intro; abstraction - | H1: ~lt ?x ?y, H2: ~eq ?y ?x |- _ => - generalize (le_neq H1 (neq_sym H2)); clear H1 H2; intro; abstraction - (* Then, we generalize all interesting facts *) - | H : ~eq ?x ?y |- _ => revert H; abstraction - | H : ~lt ?x ?y |- _ => revert H; abstraction - | H : lt ?x ?y |- _ => revert H; abstraction - | H : eq ?x ?y |- _ => revert H; abstraction - | _ => idtac -end. - -Ltac do_eq a b EQ := match goal with - | |- lt ?x ?y -> _ => let H := fresh "H" in - (intro H; - (generalize (eq_lt (eq_sym EQ) H); clear H; intro H) || - (generalize (lt_eq H EQ); clear H; intro H) || - idtac); - do_eq a b EQ - | |- ~lt ?x ?y -> _ => let H := fresh "H" in - (intro H; - (generalize (eq_le (eq_sym EQ) H); clear H; intro H) || - (generalize (le_eq H EQ); clear H; intro H) || - idtac); - do_eq a b EQ - | |- eq ?x ?y -> _ => let H := fresh "H" in - (intro H; - (generalize (eq_trans (eq_sym EQ) H); clear H; intro H) || - (generalize (eq_trans H EQ); clear H; intro H) || - idtac); - do_eq a b EQ - | |- ~eq ?x ?y -> _ => let H := fresh "H" in - (intro H; - (generalize (eq_neq (eq_sym EQ) H); clear H; intro H) || - (generalize (neq_eq H EQ); clear H; intro H) || - idtac); - do_eq a b EQ - | |- lt a ?y => apply eq_lt with b; [exact EQ|] - | |- lt ?y a => apply lt_eq with b; [|exact (eq_sym EQ)] - | |- eq a ?y => apply eq_trans with b; [exact EQ|] - | |- eq ?y a => apply eq_trans with b; [|exact (eq_sym EQ)] - | _ => idtac - end. - -Ltac propagate_eq := abstraction; clear; match goal with - (* the abstraction tactic leaves equality facts in head position...*) - | |- eq ?a ?b -> _ => - let EQ := fresh "EQ" in (intro EQ; do_eq a b EQ; clear EQ); - propagate_eq - | _ => idtac -end. - -Ltac do_lt x y LT := match goal with - (* LT *) - | |- lt x y -> _ => intros _; do_lt x y LT - | |- lt y ?z -> _ => let H := fresh "H" in - (intro H; generalize (lt_trans LT H); intro); do_lt x y LT - | |- lt ?z x -> _ => let H := fresh "H" in - (intro H; generalize (lt_trans H LT); intro); do_lt x y LT - | |- lt _ _ -> _ => intro; do_lt x y LT - (* GE *) - | |- ~lt y x -> _ => intros _; do_lt x y LT - | |- ~lt x ?z -> _ => let H := fresh "H" in - (intro H; generalize (le_lt_trans H LT); intro); do_lt x y LT - | |- ~lt ?z y -> _ => let H := fresh "H" in - (intro H; generalize (lt_le_trans LT H); intro); do_lt x y LT - | |- ~lt _ _ -> _ => intro; do_lt x y LT - | _ => idtac - end. - -Definition hide_lt := lt. - -Ltac propagate_lt := abstraction; match goal with - (* when no [=] remains, the abstraction tactic leaves [<] facts first. *) - | |- lt ?x ?y -> _ => - let LT := fresh "LT" in (intro LT; do_lt x y LT; - change (hide_lt x y) in LT); - propagate_lt - | _ => unfold hide_lt in * -end. - -Ltac order := - intros; - propagate_eq; - propagate_lt; - auto; - propagate_lt; - eauto. - -Ltac false_order := elimtype False; order. - - Lemma gt_not_eq : forall x y, lt y x -> ~ eq x y. - Proof. - order. - Qed. - - Lemma eq_not_lt : forall x y : t, eq x y -> ~ lt x y. - Proof. - order. - Qed. - - Hint Resolve gt_not_eq eq_not_lt. - - Lemma eq_not_gt : forall x y : t, eq x y -> ~ lt y x. - Proof. - order. - Qed. - - Lemma lt_not_gt : forall x y : t, lt x y -> ~ lt y x. - Proof. - order. - Qed. - - Hint Resolve eq_not_gt lt_antirefl lt_not_gt. - - Lemma elim_compare_eq : - forall x y : t, - eq x y -> exists H : eq x y, compare x y = EQ _ H. - Proof. - intros; case (compare x y); intros H'; try solve [false_order]. - exists H'; auto. - Qed. - - Lemma elim_compare_lt : - forall x y : t, - lt x y -> exists H : lt x y, compare x y = LT _ H. - Proof. - intros; case (compare x y); intros H'; try solve [false_order]. - exists H'; auto. - Qed. - - Lemma elim_compare_gt : - forall x y : t, - lt y x -> exists H : lt y x, compare x y = GT _ H. - Proof. - intros; case (compare x y); intros H'; try solve [false_order]. - exists H'; auto. - Qed. - - Ltac elim_comp := - match goal with - | |- ?e => match e with - | context ctx [ compare ?a ?b ] => - let H := fresh in - (destruct (compare a b) as [H|H|H]; - try solve [ intros; false_order]) - end - end. - - Ltac elim_comp_eq x y := - elim (elim_compare_eq (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - - Ltac elim_comp_lt x y := - elim (elim_compare_lt (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - - Ltac elim_comp_gt x y := - elim (elim_compare_gt (x:=x) (y:=y)); - [ intros _1 _2; rewrite _2; clear _1 _2 | auto ]. - - (** For compatibility reasons *) - Definition eq_dec := eq_dec. - - Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. - Proof. - intros; elim (compare x y); [ left | right | right ]; auto. - Defined. - - Definition eqb x y : bool := if eq_dec x y then true else false. - - Lemma eqb_alt : - forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. - Proof. - unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto. - Qed. - -(* Specialization of resuts about lists modulo. *) - -Section ForNotations. - -Notation In:=(InA eq). -Notation Inf:=(lelistA lt). -Notation Sort:=(sort lt). -Notation NoDup:=(NoDupA eq). - -Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. -Proof. exact (InA_eqA eq_sym eq_trans). Qed. - -Lemma ListIn_In : forall l x, List.In x l -> In x l. -Proof. exact (In_InA eq_refl). Qed. - -Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l. -Proof. exact (InfA_ltA lt_trans). Qed. - -Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l. -Proof. exact (InfA_eqA eq_lt). Qed. - -Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x. -Proof. exact (SortA_InfA_InA eq_refl eq_sym lt_trans lt_eq eq_lt). Qed. - -Lemma ListIn_Inf : forall l x, (forall y, List.In y l -> lt x y) -> Inf x l. -Proof. exact (@In_InfA t lt). Qed. - -Lemma In_Inf : forall l x, (forall y, In y l -> lt x y) -> Inf x l. -Proof. exact (InA_InfA eq_refl (ltA:=lt)). Qed. - -Lemma Inf_alt : - forall l x, Sort l -> (Inf x l <-> (forall y, In y l -> lt x y)). -Proof. exact (InfA_alt eq_refl eq_sym lt_trans lt_eq eq_lt). Qed. - -Lemma Sort_NoDup : forall l, Sort l -> NoDup l. -Proof. exact (SortA_NoDupA eq_refl eq_sym lt_trans lt_not_eq lt_eq eq_lt) . Qed. - -End ForNotations. - -Hint Resolve ListIn_In Sort_NoDup Inf_lt. -Hint Immediate In_eq Inf_lt. - -End OrderedTypeFacts. - -Module KeyOrderedType(O:OrderedType). - Import O. - Module MO:=OrderedTypeFacts(O). - Import MO. - - Section Elt. - Variable elt : Type. - Notation key:=t. - - Definition eqk (p p':key*elt) := eq (fst p) (fst p'). - Definition eqke (p p':key*elt) := - eq (fst p) (fst p') /\ (snd p) = (snd p'). - Definition ltk (p p':key*elt) := lt (fst p) (fst p'). - - Hint Unfold eqk eqke ltk. - Hint Extern 2 (eqke ?a ?b) => split. - - (* eqke is stricter than eqk *) - - Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. - Proof. - unfold eqk, eqke; intuition. - Qed. - - (* ltk ignore the second components *) - - Lemma ltk_right_r : forall x k e e', ltk x (k,e) -> ltk x (k,e'). - Proof. auto. Qed. - - Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. - Proof. auto. Qed. - Hint Immediate ltk_right_r ltk_right_l. - - (* eqk, eqke are equalities, ltk is a strict order *) - - Lemma eqk_refl : forall e, eqk e e. - Proof. auto. Qed. - - Lemma eqke_refl : forall e, eqke e e. - Proof. auto. Qed. - - Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. - Proof. auto. Qed. - - Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. - Proof. unfold eqke; intuition. Qed. - - Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. - Proof. eauto. Qed. - - Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. - Proof. - unfold eqke; intuition; [ eauto | congruence ]. - Qed. - - Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''. - Proof. eauto. Qed. - - Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. - Proof. unfold eqk, ltk; auto. Qed. - - Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. - Proof. - unfold eqke, ltk; intuition; simpl in *; subst. - exact (lt_not_eq H H1). - Qed. - - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. - Hint Immediate eqk_sym eqke_sym. - - (* Additionnal facts *) - - Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. - Proof. - unfold eqk, ltk; simpl; auto. - Qed. - - Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''. - Proof. eauto. Qed. - - Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''. - Proof. - intros (k,e) (k',e') (k'',e''). - unfold ltk, eqk; simpl; eauto. - Qed. - Hint Resolve eqk_not_ltk. - Hint Immediate ltk_eqk eqk_ltk. - - Lemma InA_eqke_eqk : - forall x m, InA eqke x m -> InA eqk x m. - Proof. - unfold eqke; induction 1; intuition. - Qed. - Hint Resolve InA_eqke_eqk. - - Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). - Definition In k m := exists e:elt, MapsTo k e m. - Notation Sort := (sort ltk). - Notation Inf := (lelistA ltk). - - Hint Unfold MapsTo In. - - (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) - - Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. - Proof. - firstorder. - exists x; auto. - induction H. - destruct y. - exists e; auto. - destruct IHInA as [e H0]. - exists e; auto. - Qed. - - Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. - Proof. - intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto. - Qed. - - Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. - Proof. - destruct 2 as (e,E); exists e; eapply MapsTo_eq; eauto. - Qed. - - Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. - Proof. exact (InfA_eqA eqk_ltk). Qed. - - Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. - Proof. exact (InfA_ltA ltk_trans). Qed. - - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. - - Lemma Sort_Inf_In : - forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. - Proof. - exact (SortA_InfA_InA eqk_refl eqk_sym ltk_trans ltk_eqk eqk_ltk). - Qed. - - Lemma Sort_Inf_NotIn : - forall l k e, Sort l -> Inf (k,e) l -> ~In k l. - Proof. - intros; red; intros. - destruct H1 as [e' H2]. - elim (@ltk_not_eqk (k,e) (k,e')). - eapply Sort_Inf_In; eauto. - red; simpl; auto. - Qed. - - Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. - Proof. - exact (SortA_NoDupA eqk_refl eqk_sym ltk_trans ltk_not_eqk ltk_eqk eqk_ltk). - Qed. - - Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. - Proof. - inversion 1; intros; eapply Sort_Inf_In; eauto. - Qed. - - Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> - ltk e e' \/ eqk e e'. - Proof. - inversion_clear 2; auto. - left; apply Sort_In_cons_1 with l; auto. - Qed. - - Lemma Sort_In_cons_3 : - forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. - Proof. - inversion_clear 1; red; intros. - destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)). - Qed. - - Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. - Proof. - inversion 1. - inversion_clear H0; eauto. - destruct H1; simpl in *; intuition. - Qed. - - Lemma In_inv_2 : forall k k' e e' l, - InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. - Proof. - inversion_clear 1; compute in H0; intuition. - Qed. - - Lemma In_inv_3 : forall x x' l, - InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. - Proof. - inversion_clear 1; compute in H0; intuition. - Qed. - - End Elt. - - Hint Unfold eqk eqke ltk. - Hint Extern 2 (eqke ?a ?b) => split. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke. - Hint Immediate eqk_sym eqke_sym. - Hint Resolve eqk_not_ltk. - Hint Immediate ltk_eqk eqk_ltk. - Hint Resolve InA_eqke_eqk. - Hint Unfold MapsTo In. - Hint Immediate Inf_eq. - Hint Resolve Inf_lt. - Hint Resolve Sort_Inf_NotIn. - Hint Resolve In_inv_2 In_inv_3. - -End KeyOrderedType. - - diff --git a/theories/FSets/OrderedTypeAlt.v b/theories/FSets/OrderedTypeAlt.v deleted file mode 100644 index 9d179995..00000000 --- a/theories/FSets/OrderedTypeAlt.v +++ /dev/null @@ -1,128 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre - * Institution: LRI, CNRS UMR 8623 - Université Paris Sud - * 91405 Orsay, France *) - -(* $Id: OrderedTypeAlt.v 11699 2008-12-18 11:49:08Z letouzey $ *) - -Require Import OrderedType. - -(** * An alternative (but equivalent) presentation for an Ordered Type - inferface. *) - -(** NB: [comparison], defined in [Datatypes.v] is [Eq|Lt|Gt] -whereas [compare], defined in [OrderedType.v] is [EQ _ | LT _ | GT _ ] -*) - -Module Type OrderedTypeAlt. - - Parameter t : Type. - - Parameter compare : t -> t -> comparison. - - Infix "?=" := compare (at level 70, no associativity). - - Parameter compare_sym : - forall x y, (y?=x) = CompOpp (x?=y). - Parameter compare_trans : - forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. - -End OrderedTypeAlt. - -(** From this new presentation to the original one. *) - -Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType. - Import O. - - Definition t := t. - - Definition eq x y := (x?=y) = Eq. - Definition lt x y := (x?=y) = Lt. - - Lemma eq_refl : forall x, eq x x. - Proof. - intro x. - unfold eq. - assert (H:=compare_sym x x). - destruct (x ?= x); simpl in *; try discriminate; auto. - Qed. - - Lemma eq_sym : forall x y, eq x y -> eq y x. - Proof. - unfold eq; intros. - rewrite compare_sym. - rewrite H; simpl; auto. - Qed. - - Definition eq_trans := (compare_trans Eq). - - Definition lt_trans := (compare_trans Lt). - - Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. - Proof. - unfold eq, lt; intros. - rewrite H; discriminate. - Qed. - - Definition compare : forall x y, Compare lt eq x y. - Proof. - intros. - case_eq (x ?= y); intros. - apply EQ; auto. - apply LT; auto. - apply GT; red. - rewrite compare_sym; rewrite H; auto. - Defined. - - Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. - Proof. - intros; unfold eq. - case (x ?= y); [ left | right | right ]; auto; discriminate. - Defined. - -End OrderedType_from_Alt. - -(** From the original presentation to this alternative one. *) - -Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt. - Import O. - Module MO:=OrderedTypeFacts(O). - Import MO. - - Definition t := t. - - Definition compare x y := match compare x y with - | LT _ => Lt - | EQ _ => Eq - | GT _ => Gt - end. - - Infix "?=" := compare (at level 70, no associativity). - - Lemma compare_sym : - forall x y, (y?=x) = CompOpp (x?=y). - Proof. - intros x y; unfold compare. - destruct O.compare; elim_comp; simpl; auto. - Qed. - - Lemma compare_trans : - forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. - Proof. - intros c x y z. - destruct c; unfold compare; - do 2 (destruct O.compare; intros; try discriminate); - elim_comp; auto. - Qed. - -End OrderedType_to_Alt. - - diff --git a/theories/FSets/OrderedTypeEx.v b/theories/FSets/OrderedTypeEx.v deleted file mode 100644 index 03e3ab83..00000000 --- a/theories/FSets/OrderedTypeEx.v +++ /dev/null @@ -1,269 +0,0 @@ -(***********************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) -(* \VV/ *************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(***********************************************************************) - -(* Finite sets library. - * Authors: Pierre Letouzey and Jean-Christophe Filliâtre - * Institution: LRI, CNRS UMR 8623 - Université Paris Sud - * 91405 Orsay, France *) - -(* $Id: OrderedTypeEx.v 11699 2008-12-18 11:49:08Z letouzey $ *) - -Require Import OrderedType. -Require Import ZArith. -Require Import Omega. -Require Import NArith Ndec. -Require Import Compare_dec. - -(** * Examples of Ordered Type structures. *) - -(** First, a particular case of [OrderedType] where - the equality is the usual one of Coq. *) - -Module Type UsualOrderedType. - Parameter Inline t : Type. - Definition eq := @eq t. - Parameter Inline lt : t -> t -> Prop. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - Axiom lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Axiom lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Parameter compare : forall x y : t, Compare lt eq x y. - Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }. -End UsualOrderedType. - -(** a [UsualOrderedType] is in particular an [OrderedType]. *) - -Module UOT_to_OT (U:UsualOrderedType) <: OrderedType := U. - -(** [nat] is an ordered type with respect to the usual order on natural numbers. *) - -Module Nat_as_OT <: UsualOrderedType. - - Definition t := nat. - - Definition eq := @eq nat. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - - Definition lt := lt. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. unfold lt in |- *; intros; apply lt_trans with y; auto. Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. unfold lt, eq in |- *; intros; omega. Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - Proof. - intros; case (lt_eq_lt_dec x y). - simple destruct 1; intro. - constructor 1; auto. - constructor 2; auto. - intro; constructor 3; auto. - Defined. - - Definition eq_dec := eq_nat_dec. - -End Nat_as_OT. - - -(** [Z] is an ordered type with respect to the usual order on integers. *) - -Open Local Scope Z_scope. - -Module Z_as_OT <: UsualOrderedType. - - Definition t := Z. - Definition eq := @eq Z. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - - Definition lt (x y:Z) := (x<y). - - Lemma lt_trans : forall x y z, x<y -> y<z -> x<z. - Proof. intros; omega. Qed. - - Lemma lt_not_eq : forall x y, x<y -> ~ x=y. - Proof. intros; omega. Qed. - - Definition compare : forall x y, Compare lt eq x y. - Proof. - intros x y; case_eq (x ?= y); intros. - apply EQ; unfold eq; apply Zcompare_Eq_eq; auto. - apply LT; unfold lt, Zlt; auto. - apply GT; unfold lt, Zlt; rewrite <- Zcompare_Gt_Lt_antisym; auto. - Defined. - - Definition eq_dec := Z_eq_dec. - -End Z_as_OT. - -(** [positive] is an ordered type with respect to the usual order on natural numbers. *) - -Open Local Scope positive_scope. - -Module Positive_as_OT <: UsualOrderedType. - Definition t:=positive. - Definition eq:=@eq positive. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - - Definition lt p q:= (p ?= q) Eq = Lt. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. - unfold lt; intros x y z. - change ((Zpos x < Zpos y)%Z -> (Zpos y < Zpos z)%Z -> (Zpos x < Zpos z)%Z). - omega. - Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros; intro. - rewrite H0 in H. - unfold lt in H. - rewrite Pcompare_refl in H; discriminate. - Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - Proof. - intros x y. - case_eq ((x ?= y) Eq); intros. - apply EQ; apply Pcompare_Eq_eq; auto. - apply LT; unfold lt; auto. - apply GT; unfold lt. - replace Eq with (CompOpp Eq); auto. - rewrite <- Pcompare_antisym; rewrite H; auto. - Defined. - - Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. - Proof. - intros; unfold eq; decide equality. - Defined. - -End Positive_as_OT. - - -(** [N] is an ordered type with respect to the usual order on natural numbers. *) - -Open Local Scope positive_scope. - -Module N_as_OT <: UsualOrderedType. - Definition t:=N. - Definition eq:=@eq N. - Definition eq_refl := @refl_equal t. - Definition eq_sym := @sym_eq t. - Definition eq_trans := @trans_eq t. - - Definition lt p q:= Nleb q p = false. - - Definition lt_trans := Nltb_trans. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros; intro. - rewrite H0 in H. - unfold lt in H. - rewrite Nleb_refl in H; discriminate. - Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - Proof. - intros x y. - case_eq ((x ?= y)%N); intros. - apply EQ; apply Ncompare_Eq_eq; auto. - apply LT; unfold lt; auto. - generalize (Nleb_Nle y x). - unfold Nle; rewrite <- Ncompare_antisym. - destruct (x ?= y)%N; simpl; try discriminate. - clear H; intros H. - destruct (Nleb y x); intuition. - apply GT; unfold lt. - generalize (Nleb_Nle x y). - unfold Nle; destruct (x ?= y)%N; simpl; try discriminate. - destruct (Nleb x y); intuition. - Defined. - - Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. - Proof. - intros. unfold eq. decide equality. apply Positive_as_OT.eq_dec. - Defined. - -End N_as_OT. - - -(** From two ordered types, we can build a new OrderedType - over their cartesian product, using the lexicographic order. *) - -Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. - Module MO1:=OrderedTypeFacts(O1). - Module MO2:=OrderedTypeFacts(O2). - - Definition t := prod O1.t O2.t. - - Definition eq x y := O1.eq (fst x) (fst y) /\ O2.eq (snd x) (snd y). - - Definition lt x y := - O1.lt (fst x) (fst y) \/ - (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)). - - Lemma eq_refl : forall x : t, eq x x. - Proof. - intros (x1,x2); red; simpl; auto. - Qed. - - Lemma eq_sym : forall x y : t, eq x y -> eq y x. - Proof. - intros (x1,x2) (y1,y2); unfold eq; simpl; intuition. - Qed. - - Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. - Proof. - intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto. - Qed. - - Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. - Proof. - intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition. - left; eauto. - left; eapply MO1.lt_eq; eauto. - left; eapply MO1.eq_lt; eauto. - right; split; eauto. - Qed. - - Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. - intros (x1,x2) (y1,y2); unfold eq, lt; simpl; intuition. - apply (O1.lt_not_eq H0 H1). - apply (O2.lt_not_eq H3 H2). - Qed. - - Definition compare : forall x y : t, Compare lt eq x y. - intros (x1,x2) (y1,y2). - destruct (O1.compare x1 y1). - apply LT; unfold lt; auto. - destruct (O2.compare x2 y2). - apply LT; unfold lt; auto. - apply EQ; unfold eq; auto. - apply GT; unfold lt; auto. - apply GT; unfold lt; auto. - Defined. - - Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. - Proof. - intros; elim (compare x y); intro H; [ right | left | right ]; auto. - auto using lt_not_eq. - assert (~ eq y x); auto using lt_not_eq, eq_sym. - Defined. - -End PairOrderedType. - diff --git a/theories/FSets/vo.itarget b/theories/FSets/vo.itarget new file mode 100644 index 00000000..0e7c11fb --- /dev/null +++ b/theories/FSets/vo.itarget @@ -0,0 +1,21 @@ +FMapAVL.vo +FMapFacts.vo +FMapFullAVL.vo +FMapInterface.vo +FMapList.vo +FMapPositive.vo +FMaps.vo +FMapWeakList.vo +FSetCompat.vo +FSetAVL.vo +FSetPositive.vo +FSetBridge.vo +FSetDecide.vo +FSetEqProperties.vo +FSetFacts.vo +FSetInterface.vo +FSetList.vo +FSetProperties.vo +FSets.vo +FSetToFiniteSet.vo +FSetWeakList.vo |