diff options
Diffstat (limited to 'theories/FSets')
| -rw-r--r-- | theories/FSets/DecidableType.v | 151 | ||||
| -rw-r--r-- | theories/FSets/FMapInterface.v | 245 | ||||
| -rw-r--r-- | theories/FSets/FMapList.v | 1271 | ||||
| -rw-r--r-- | theories/FSets/FMapWeak.v | 12 | ||||
| -rw-r--r-- | theories/FSets/FMapWeakInterface.v | 201 | ||||
| -rw-r--r-- | theories/FSets/FMapWeakList.v | 960 | ||||
| -rw-r--r-- | theories/FSets/FMaps.v | 12 | ||||
| -rw-r--r-- | theories/FSets/FSetBridge.v | 750 | ||||
| -rw-r--r-- | theories/FSets/FSetEqProperties.v | 923 | ||||
| -rw-r--r-- | theories/FSets/FSetFacts.v | 409 | ||||
| -rw-r--r-- | theories/FSets/FSetInterface.v | 420 | ||||
| -rw-r--r-- | theories/FSets/FSetList.v | 1163 | ||||
| -rw-r--r-- | theories/FSets/FSetProperties.v | 1007 | ||||
| -rw-r--r-- | theories/FSets/FSetWeak.v | 14 | ||||
| -rw-r--r-- | theories/FSets/FSetWeakFacts.v | 415 | ||||
| -rw-r--r-- | theories/FSets/FSetWeakInterface.v | 248 | ||||
| -rw-r--r-- | theories/FSets/FSetWeakList.v | 873 | ||||
| -rw-r--r-- | theories/FSets/FSets.v | 16 | ||||
| -rw-r--r-- | theories/FSets/OrderedType.v | 566 |
19 files changed, 9656 insertions, 0 deletions
diff --git a/theories/FSets/DecidableType.v b/theories/FSets/DecidableType.v new file mode 100644 index 00000000..635f6bdb --- /dev/null +++ b/theories/FSets/DecidableType.v @@ -0,0 +1,151 @@ +(***********************************************************************) +(* 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: DecidableType.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +Require Export SetoidList. +Set Implicit Arguments. +Unset Strict Implicit. + +(** * Types with decidable Equalities (but no ordering) *) + +Module Type DecidableType. + + Parameter t : Set. + + Parameter eq : t -> t -> Prop. + + Axiom eq_refl : forall x : t, eq x x. + Axiom eq_sym : forall x y : t, eq x y -> eq y x. + Axiom eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. + + Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }. + + Hint Immediate eq_sym. + Hint Resolve eq_refl eq_trans. + +End DecidableType. + + +Module PairDecidableType(D:DecidableType). + Import D. + + Section Elt. + Variable elt : Set. + 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'). + + Hint Unfold eqk eqke. + Hint Extern 2 (eqke ?a ?b) => split. + + (* eqke is stricter than eqk *) + + Lemma eqke_eqk : forall x x', eqke x x' -> eqk x x'. + Proof. + unfold eqk, eqke; intuition. + Qed. + + (* eqk, eqke are equalities *) + + 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. + + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. + Hint Immediate eqk_sym eqke_sym. + + 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. + + Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. + Proof. + intros; apply InA_eqA with p; auto; apply eqk_trans; auto. + Qed. + + Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). + Definition In k m := exists e:elt, MapsTo k e m. + + 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 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. + Hint Extern 2 (eqke ?a ?b) => split. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl. + Hint Immediate eqk_sym eqke_sym. + Hint Resolve InA_eqke_eqk. + Hint Unfold MapsTo In. + Hint Resolve In_inv_2 In_inv_3. + + +End PairDecidableType. diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v new file mode 100644 index 00000000..dde74a0a --- /dev/null +++ b/theories/FSets/FMapInterface.v @@ -0,0 +1,245 @@ +(***********************************************************************) +(* 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: FMapInterface.v 8671 2006-03-29 08:31:28Z letouzey $ *) + +(** * Finite map library *) + +(** This file proposes an interface for finite maps *) + +(* begin hide *) +Set Implicit Arguments. +Unset Strict Implicit. +Require Import FSetInterface. +(* end hide *) + +(** When compared with Ocaml Map, this signature has been split in two: + - The first part [S] contains the usual operators (add, find, ...) + It only requires a ordered key type, the data type can be arbitrary. + The only function that asks more is [equal], whose first argument should + be an equality on data. + - Then, [Sord] extends [S] with a complete comparison function. For + that, the data type should have a decidable total ordering. +*) + + +Module Type S. + + Declare Module E : OrderedType. + + Definition key := E.t. + + Parameter t : Set -> Set. (** the abstract type of maps *) + + Section Types. + + Variable elt:Set. + + Parameter empty : t elt. + (** The empty map. *) + + Parameter is_empty : t elt -> bool. + (** Test whether a map is empty or not. *) + + Parameter add : key -> elt -> t elt -> t elt. + (** [add x y m] returns a map containing the same bindings as [m], + plus a binding of [x] to [y]. If [x] was already bound in [m], + its previous binding disappears. *) + + Parameter find : key -> t elt -> option elt. + (** [find x m] returns the current binding of [x] in [m], + or raises [Not_found] if no such binding exists. + NB: in Coq, the exception mechanism becomes a option type. *) + + Parameter remove : key -> t elt -> t elt. + (** [remove x m] returns a map containing the same bindings as [m], + except for [x] which is unbound in the returned map. *) + + Parameter mem : key -> t elt -> bool. + (** [mem x m] returns [true] if [m] contains a binding for [x], + and [false] otherwise. *) + + (** Coq comment: [iter] is useless in a purely functional world *) + (** val iter : (key -> 'a -> unit) -> 'a t -> unit *) + (** iter f m applies f to all bindings in map m. f receives the key as + first argument, and the associated value as second argument. + The bindings are passed to f in increasing order with respect to the + ordering over the type of the keys. Only current bindings are + presented to f: bindings hidden by more recent bindings are not + passed to f. *) + + Variable elt' : Set. + Variable elt'': Set. + + Parameter map : (elt -> elt') -> t elt -> t elt'. + (** [map f m] returns a map with same domain as [m], where the associated + value a of all bindings of [m] has been replaced by the result of the + application of [f] to [a]. The bindings are passed to [f] in + increasing order with respect to the ordering over the type of the + keys. *) + + Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. + (** Same as [S.map], but the function receives as arguments both the + key and the associated value for each binding of the map. *) + + Parameter map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' -> t elt''. + (** Not present in Ocaml. + [map 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). + (** Not present in Ocaml. + [elements m] returns an assoc list corresponding to the bindings of [m]. + Elements of this list are sorted with respect to their first components. + Useful to specify [fold] ... *) + + Parameter fold : forall A: Set, (key -> elt -> A -> A) -> t elt -> A -> A. + (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1] ... [kN] are the keys of all bindings in [m] + (in increasing order), and [d1] ... [dN] are the associated data. *) + + Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. + (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, + that is, contain equal keys and associate them with equal data. + [cmp] is the equality predicate used to compare the data associated + with the keys. *) + + Section Spec. + + Variable m m' m'' : t elt. + Variable x y z : key. + Variable e e' : elt. + + Parameter MapsTo : key -> elt -> t elt -> Prop. + + Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m. + + Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. + + Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p'). + + Definition eq_key_elt (p p':key*elt) := + E.eq (fst p) (fst p') /\ (snd p) = (snd p'). + + Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p'). + + (** Specification of [MapsTo] *) + Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. + + (** Specification of [mem] *) + Parameter mem_1 : In x m -> mem x m = true. + Parameter mem_2 : mem x m = true -> In x m. + + (** Specification of [empty] *) + Parameter empty_1 : Empty empty. + + (** Specification of [is_empty] *) + Parameter is_empty_1 : Empty m -> is_empty m = true. + Parameter is_empty_2 : is_empty m = true -> Empty m. + + (** Specification of [add] *) + Parameter add_1 : E.eq x y -> MapsTo y e (add x e m). + Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). + Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. + + (** Specification of [remove] *) + Parameter remove_1 : E.eq x y -> ~ In y (remove x m). + Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). + Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. + + (** Specification of [find] *) + Parameter find_1 : MapsTo x e m -> find x m = Some e. + Parameter find_2 : find x m = Some e -> MapsTo x e m. + + (** Specification of [elements] *) + Parameter elements_1 : + MapsTo x e m -> InA eq_key_elt (x,e) (elements m). + Parameter elements_2 : + InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. + Parameter elements_3 : sort lt_key (elements m). + + (** Specification of [fold] *) + Parameter fold_1 : + forall (A : Set) (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. + + Definition Equal 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). + + Variable cmp : elt -> elt -> bool. + + (** Specification of [equal] *) + Parameter equal_1 : Equal cmp m m' -> equal cmp m m' = true. + Parameter equal_2 : equal cmp m m' = true -> Equal cmp m m'. + + End Spec. + End Types. + + (** Specification of [map] *) + Parameter map_1 : forall (elt elt':Set)(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':Set)(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':Set)(m: t elt)(x:key)(e:elt) + (f:key->elt->elt'), MapsTo x e m -> + exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). + Parameter mapi_2 : forall (elt elt':Set)(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'':Set)(m: t elt)(m': t elt') + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + + Parameter map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') + (x:key)(f:option elt->option elt'->option elt''), + In x (map2 f m m') -> In x m \/ In x m'. + + (* begin hide *) + Hint Immediate MapsTo_1 mem_2 is_empty_2. + + Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 add_3 remove_1 + remove_2 remove_3 find_1 find_2 fold_1 map_1 map_2 mapi_1 mapi_2. + (* end hide *) + +End S. + + +Module Type Sord. + + Declare Module Data : OrderedType. + Declare Module MapS : S. + Import MapS. + + Definition t := MapS.t Data.t. + + Parameter eq : t -> t -> Prop. + Parameter lt : t -> t -> Prop. + + Axiom eq_refl : forall m : t, eq m m. + Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. + Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. + Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. + Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. + + Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end. + + Parameter eq_1 : forall m m', Equal cmp m m' -> eq m m'. + Parameter eq_2 : forall m m', eq m m' -> Equal cmp m m'. + + Parameter compare : forall m1 m2, Compare lt eq m1 m2. + (** Total ordering between maps. The first argument (in Coq: Data.compare) + is a total ordering used to compare data associated with equal keys + in the two maps. *) + +End Sord.
\ No newline at end of file diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v new file mode 100644 index 00000000..2d083d5b --- /dev/null +++ b/theories/FSets/FMapList.v @@ -0,0 +1,1271 @@ +(***********************************************************************) +(* 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: FMapList.v 8667 2006-03-28 11:59:44Z letouzey $ *) + +(** * Finite map library *) + +(** This file proposes an implementation of the non-dependant interface + [FMapInterface.S] using lists of pairs ordered (increasing) with respect to + left projection. *) + +Require Import FSetInterface. +Require Import FMapInterface. + +Set Implicit Arguments. +Unset Strict Implicit. + +Arguments Scope list [type_scope]. + +Module Raw (X:OrderedType). + +Module E := X. +Module MX := OrderedTypeFacts X. +Module PX := PairOrderedType X. +Import MX. +Import PX. + +Definition key := X.t. +Definition t (elt:Set) := list (X.t * elt). + +Section Elt. +Variable elt : Set. + +(* Now in PairOrderedtype: +Definition eqk (p p':key*elt) := X.eq (fst p) (fst p'). +Definition eqke (p p':key*elt) := + X.eq (fst p) (fst p') /\ (snd p) = (snd p'). +Definition ltk (p p':key*elt) := X.lt (fst p) (fst p'). +Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). +Definition In k m := exists e:elt, MapsTo k e m. +*) + +Notation eqk := (eqk (elt:=elt)). +Notation eqke := (eqke (elt:=elt)). +Notation ltk := (ltk (elt:=elt)). +Notation MapsTo := (MapsTo (elt:=elt)). +Notation In := (In (elt:=elt)). +Notation Sort := (sort ltk). +Notation Inf := (lelistA (ltk)). + +(** * [empty] *) + +Definition empty : t elt := nil. + +Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. + +Lemma empty_1 : Empty empty. +Proof. + unfold Empty,empty. + intros a e. + intro abs. + inversion abs. +Qed. +Hint Resolve empty_1. + +Lemma empty_sorted : Sort empty. +Proof. + unfold empty; auto. +Qed. + +(** * [is_empty] *) + +Definition is_empty (l : t elt) : bool := if l then true else false. + +Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. +Proof. + unfold Empty, PX.MapsTo. + intros m. + case m;auto. + intros (k,e) l inlist. + absurd (InA eqke (k, e) ((k, e) :: l));auto. +Qed. + +Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. +Proof. + intros m. + case m;auto. + intros p l abs. + inversion abs. +Qed. + +(** * [mem] *) + +Fixpoint mem (k : key) (s : t elt) {struct s} : bool := + match s with + | nil => false + | (k',_) :: l => + match X.compare k k' with + | LT _ => false + | EQ _ => true + | GT _ => mem k l + end + end. + +Lemma mem_1 : forall m (Hm:Sort m) x, In x m -> mem x m = true. +Proof. + intros m Hm x; generalize Hm; clear Hm. + functional induction mem x m;intros sorted belong1;trivial. + + inversion belong1. inversion H. + + absurd (In k ((k', e) :: l));try assumption. + apply Sort_Inf_NotIn with e;auto. + + apply H. + elim (sort_inv sorted);auto. + elim (In_inv belong1);auto. + intro abs. + absurd (X.eq k k');auto. +Qed. + +Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. +Proof. + intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. + functional induction mem x m; intros sorted hyp;try ((inversion hyp);fail). + exists e; auto. + induction H; auto. + exists x; auto. + inversion_clear sorted; auto. +Qed. + +(** * [find] *) + +Fixpoint find (k:key) (s: t elt) {struct s} : option elt := + match s with + | nil => None + | (k',x)::s' => + match X.compare k k' with + | LT _ => None + | EQ _ => Some x + | GT _ => find k s' + end + end. + +Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. +Proof. + intros m x. unfold PX.MapsTo. + functional induction find x m;simpl;intros e' eqfind; inversion eqfind; auto. +Qed. + +Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. +Proof. + intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction find x m;simpl; subst; try clear H_eq_1. + + inversion 2. + + inversion_clear 2. + compute in H0; destruct H0; order. + generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. + + inversion_clear 2. + compute in H0; destruct H0; intuition congruence. + generalize (Sort_In_cons_1 Hm (InA_eqke_eqk H0)); compute; order. + + do 2 inversion_clear 1; auto. + compute in H3; destruct H3; order. +Qed. + +(** * [add] *) + +Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt := + match s with + | nil => (k,x) :: nil + | (k',y) :: l => + match X.compare k k' with + | LT _ => (k,x)::s + | EQ _ => (k,x)::l + | GT _ => (k',y) :: add k x l + end + end. + +Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). +Proof. + intros m x y e; generalize y; clear y. + unfold PX.MapsTo. + functional induction add x e m;simpl;auto. +Qed. + +Lemma add_2 : forall m x y e e', + ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). +Proof. + intros m x y e e'. + generalize y e; clear y e; unfold PX.MapsTo. + functional induction add x e' m;simpl;auto; clear H_eq_1. + intros y' e' eqky'; inversion_clear 1; destruct H0; simpl in *. + order. + auto. + auto. + intros y' e' eqky'; inversion_clear 1; intuition. +Qed. + +Lemma add_3 : forall m x y e e', + ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. +Proof. + intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. + functional induction add x e' m;simpl; intros. + apply (In_inv_3 H0); compute; auto. + apply (In_inv_3 H0); compute; auto. + constructor 2; apply (In_inv_3 H0); compute; auto. + inversion_clear H1; auto. +Qed. + +Lemma add_Inf : forall (m:t elt)(x x':key)(e e':elt), + Inf (x',e') m -> ltk (x',e') (x,e) -> Inf (x',e') (add x e m). +Proof. + induction m. + simpl; intuition. + intros. + destruct a as (x'',e''). + inversion_clear H. + compute in H0,H1. + simpl; case (X.compare x x''); intuition. +Qed. +Hint Resolve add_Inf. + +Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). +Proof. + induction m. + simpl; intuition. + intros. + destruct a as (x',e'). + simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. + constructor; auto. + apply Inf_eq with (x',e'); auto. +Qed. + +(** * [remove] *) + +Fixpoint remove (k : key) (s : t elt) {struct s} : t elt := + match s with + | nil => nil + | (k',x) :: l => + match X.compare k k' with + | LT _ => s + | EQ _ => l + | GT _ => (k',x) :: remove k l + end + end. + +Lemma remove_1 : forall m (Hm:Sort m) x y, X.eq x y -> ~ In y (remove x m). +Proof. + intros m Hm x y; generalize Hm; clear Hm. + functional induction remove x m;simpl;intros;subst;try clear H_eq_1. + + red; inversion 1; inversion H1. + + apply Sort_Inf_NotIn with x; auto. + constructor; compute; order. + + inversion_clear Hm. + apply Sort_Inf_NotIn with x; auto. + apply Inf_eq with (k',x);auto; compute; apply X.eq_trans with k; auto. + + inversion_clear Hm. + assert (notin:~ In y (remove k l)) by auto. + intros (x0,abs). + inversion_clear abs. + compute in H3; destruct H3; order. + apply notin; exists x0; auto. +Qed. + +Lemma remove_2 : forall m (Hm:Sort m) x y e, + ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). +Proof. + intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction remove x m;auto; try clear H_eq_1. + inversion_clear 3; auto. + compute in H1; destruct H1; order. + + inversion_clear 1; inversion_clear 2; auto. +Qed. + +Lemma remove_3 : forall m (Hm:Sort m) x y e, + MapsTo y e (remove x m) -> MapsTo y e m. +Proof. + intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction remove x m;auto. + inversion_clear 1; inversion_clear 1; auto. +Qed. + +Lemma remove_Inf : forall (m:t elt)(Hm : Sort m)(x x':key)(e':elt), + Inf (x',e') m -> Inf (x',e') (remove x m). +Proof. + induction m. + simpl; intuition. + intros. + destruct a as (x'',e''). + inversion_clear H. + compute in H0. + simpl; case (X.compare x x''); intuition. + inversion_clear Hm. + apply Inf_lt with (x'',e''); auto. +Qed. +Hint Resolve remove_Inf. + +Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). +Proof. + induction m. + simpl; intuition. + intros. + destruct a as (x',e'). + simpl; case (X.compare x x'); intuition; inversion_clear Hm; auto. +Qed. + +(** * [elements] *) + +Definition elements (m: t elt) := m. + +Lemma elements_1 : forall m x e, + MapsTo x e m -> InA eqke (x,e) (elements m). +Proof. + auto. +Qed. + +Lemma elements_2 : forall m x e, + InA eqke (x,e) (elements m) -> MapsTo x e m. +Proof. + auto. +Qed. + +Lemma elements_3 : forall m (Hm:Sort m), sort ltk (elements m). +Proof. + auto. +Qed. + +(** * [fold] *) + +Fixpoint fold (A:Set)(f:key->elt->A->A)(m:t elt) {struct m} : A -> A := + fun acc => + match m with + | nil => acc + | (k,e)::m' => fold f m' (f k e acc) + end. + +Lemma fold_1 : forall m (A:Set)(i:A)(f:key->elt->A->A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. +Proof. + intros; functional induction fold A f m i; auto. +Qed. + +(** * [equal] *) + +Fixpoint equal (cmp:elt->elt->bool)(m m' : t elt) { struct m } : bool := + match m, m' with + | nil, nil => true + | (x,e)::l, (x',e')::l' => + match X.compare x x' with + | EQ _ => cmp e e' && equal cmp l l' + | _ => false + end + | _, _ => false + end. + +Definition Equal 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, + Equal 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; auto; unfold Equal; + intuition; subst; try clear H_eq_3. + + destruct p as (k,e). + destruct (H0 k). + destruct H2. + exists e; auto. + inversion H2. + + destruct (H0 x). + destruct H. + exists e; auto. + inversion H. + + destruct (H0 x). + assert (In x ((x',e')::l')). + apply H; auto. + exists e; auto. + destruct (In_inv H3). + order. + inversion_clear Hm'. + assert (Inf (x,e) l'). + apply Inf_lt with (x',e'); auto. + elim (Sort_Inf_NotIn H5 H7 H4). + + assert (cmp e e' = true). + apply H2 with x; auto. + rewrite H0; simpl. + apply H; auto. + inversion_clear Hm; auto. + inversion_clear Hm'; auto. + unfold Equal; intuition. + destruct (H1 k). + assert (In k ((x,e) ::l)). + destruct H3 as (e'', hyp); exists e''; auto. + destruct (In_inv (H4 H6)); auto. + inversion_clear Hm. + elim (Sort_Inf_NotIn H8 H9). + destruct H3 as (e'', hyp); exists e''; auto. + apply MapsTo_eq with k; auto; order. + destruct (H1 k). + assert (In k ((x',e') ::l')). + destruct H3 as (e'', hyp); exists e''; auto. + destruct (In_inv (H5 H6)); auto. + inversion_clear Hm'. + elim (Sort_Inf_NotIn H8 H9). + destruct H3 as (e'', hyp); exists e''; auto. + apply MapsTo_eq with k; auto; order. + apply H2 with k; destruct (eq_dec x k); auto. + + destruct (H0 x'). + assert (In x' ((x,e)::l)). + apply H2; auto. + exists e'; auto. + destruct (In_inv H3). + order. + inversion_clear Hm. + assert (Inf (x',e') l). + apply Inf_lt with (x,e); auto. + elim (Sort_Inf_NotIn H5 H7 H4). +Qed. + +Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, + equal cmp m m' = true -> Equal cmp m m'. +Proof. + intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. + functional induction equal cmp m m'; simpl; auto; unfold Equal; + intuition; try discriminate; subst; try clear H_eq_3; + try solve [inversion H0]; destruct (andb_prop _ _ H0); clear H0; + inversion_clear Hm; inversion_clear Hm'. + + destruct (H H0 H5 H3). + destruct (In_inv H1). + exists e'; constructor; split; trivial; apply X.eq_trans with x; auto. + destruct (H7 k). + destruct (H10 H9) as (e'',hyp). + exists e''; auto. + + destruct (H H0 H5 H3). + destruct (In_inv H1). + exists e; constructor; split; trivial; apply X.eq_trans with x'; auto. + destruct (H7 k). + destruct (H11 H9) as (e'',hyp). + exists e''; auto. + + destruct (H H0 H6 H4). + inversion_clear H1. + destruct H10; simpl in *; subst. + inversion_clear H2. + destruct H10; simpl in *; subst; auto. + elim (Sort_Inf_NotIn H6 H7). + exists e'0; apply MapsTo_eq with k; auto; order. + inversion_clear H2. + destruct H1; simpl in *; subst; auto. + elim (Sort_Inf_NotIn H0 H5). + exists e1; apply MapsTo_eq with k; auto; order. + apply H9 with k; auto. +Qed. + +(** This lemma isn't part of the spec of [Equal], 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 -> + (Equal cmp l1 l2 <-> Equal cmp (x :: l1) (y :: l2)). +Proof. + intros. + inversion H; subst. + inversion H0; subst. + destruct x; destruct y; compute in H1, H2. + split; intros. + apply equal_2; auto. + simpl. + elim_comp. + rewrite H2; simpl. + apply equal_1; auto. + apply equal_2; auto. + generalize (equal_1 H H0 H3). + simpl. + elim_comp. + rewrite H2; simpl; auto. +Qed. + +Variable elt':Set. + +(** * [map] and [mapi] *) + +Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : 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' := + match m with + | nil => nil + | (k,e)::m' => (k,f k e) :: mapi f m' + end. + +End Elt. +Section Elt2. +(* A new section is necessary for previous definitions to work + with different [elt], especially [MapsTo]... *) + +Variable elt elt' : Set. + +(** Specification of [map] *) + +Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), + MapsTo x e m -> MapsTo x (f e) (map f m). +Proof. + intros m x e f. + (* functional induction map elt elt' f m. *) (* Marche pas ??? *) + induction m. + inversion 1. + + destruct a as (x',e'). + simpl. + inversion_clear 1. + constructor 1. + unfold eqke in *; simpl in *; intuition congruence. + constructor 2. + unfold MapsTo in *; auto. +Qed. + +Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. +Proof. + intros m x f. + (* functional induction map elt elt' f m. *) (* Marche pas ??? *) + induction m; simpl. + intros (e,abs). + inversion abs. + + destruct a as (x',e). + intros hyp. + inversion hyp. clear hyp. + inversion H; subst; rename x0 into e'. + exists e; constructor. + unfold eqke in *; simpl in *; intuition. + destruct IHm as (e'',hyp). + exists e'; auto. + exists e''. + constructor 2; auto. +Qed. + +Lemma map_lelistA : forall (m: t elt)(x:key)(e:elt)(e':elt')(f:elt->elt'), + lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt') (x,e') (map f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x0,e0). + inversion_clear H; auto. +Qed. + +Hint Resolve map_lelistA. + +Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), + sort (@ltk elt') (map f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm. + constructor; auto. + exact (map_lelistA _ _ H0). +Qed. + +(** Specification of [mapi] *) + +Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> + exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). +Proof. + intros m x e f. + (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) + induction m. + inversion 1. + + destruct a as (x',e'). + simpl. + inversion_clear 1. + exists x'. + destruct H0; simpl in *. + split; auto. + constructor 1. + unfold eqke in *; simpl in *; intuition congruence. + destruct IHm as (y, hyp); auto. + exists y; intuition. +Qed. + + +Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), + In x (mapi f m) -> In x m. +Proof. + intros m x f. + (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) + induction m; simpl. + intros (e,abs). + inversion abs. + + destruct a as (x',e). + intros hyp. + inversion hyp. clear hyp. + inversion H; subst; rename x0 into e'. + exists e; constructor. + unfold eqke in *; simpl in *; intuition. + destruct IHm as (e'',hyp). + exists e'; auto. + exists e''. + constructor 2; auto. +Qed. + +Lemma mapi_lelistA : forall (m: t elt)(x:key)(e:elt)(f:key->elt->elt'), + lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt') (x,f x e) (mapi f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear H; auto. +Qed. + +Hint Resolve mapi_lelistA. + +Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), + sort (@ltk elt') (mapi f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm; auto. +Qed. + +End Elt2. +Section Elt3. + +(** * [map2] *) + +Variable elt elt' elt'' : Set. +Variable f : option elt -> option elt' -> option elt''. + +Definition option_cons (A:Set)(k:key)(o:option A)(l:list (key*A)) := + match o with + | Some e => (k,e)::l + | None => l + end. + +Fixpoint map2_l (m : t elt) : t elt'' := + match m with + | nil => nil + | (k,e)::l => option_cons k (f (Some e) None) (map2_l l) + end. + +Fixpoint map2_r (m' : t elt') : t elt'' := + match m' with + | nil => nil + | (k,e')::l' => option_cons k (f None (Some e')) (map2_r l') + end. + +Fixpoint map2 (m : t elt) : t elt' -> t elt'' := + match m with + | nil => map2_r + | (k,e) :: l => + fix map2_aux (m' : t elt') : t elt'' := + match m' with + | nil => map2_l m + | (k',e') :: l' => + match X.compare k k' with + | LT _ => option_cons k (f (Some e) None) (map2 l m') + | EQ _ => option_cons k (f (Some e) (Some e')) (map2 l l') + | GT _ => option_cons k' (f None (Some e')) (map2_aux l') + end + end + end. + +Notation oee' := (option elt * option elt')%type. + +Fixpoint combine (m : t elt) : t elt' -> t oee' := + match m with + | nil => map (fun e' => (None,Some e')) + | (k,e) :: l => + fix combine_aux (m':t elt') : list (key * oee') := + match m' with + | nil => map (fun e => (Some e,None)) m + | (k',e') :: l' => + match X.compare k k' with + | LT _ => (k,(Some e, None))::combine l m' + | EQ _ => (k,(Some e, Some e'))::combine l l' + | GT _ => (k',(None,Some e'))::combine_aux l' + end + end + end. + +Definition fold_right_pair (A B C:Set)(f: A->B->C->C)(l:list (A*B))(i:C) := + List.fold_right (fun p => f (fst p) (snd p)) i l. + +Definition map2_alt m m' := + let m0 : t oee' := combine m m' in + let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in + fold_right_pair (option_cons (A:=elt'')) m1 nil. + +Lemma map2_alt_equiv : forall m m', map2_alt m m' = map2 m m'. +Proof. + unfold map2_alt. + induction m. + simpl; auto; intros. + (* map2_r *) + induction m'; try destruct a; simpl; auto. + rewrite IHm'; auto. + (* fin map2_r *) + induction m'; destruct a. + simpl; f_equal. + (* map2_l *) + clear IHm. + induction m; try destruct a; simpl; auto. + rewrite IHm; auto. + (* fin map2_l *) + destruct a0. + simpl. + destruct (X.compare t0 t1); simpl; f_equal. + apply IHm. + apply IHm. + apply IHm'. +Qed. + +Lemma combine_lelistA : + forall m m' (x:key)(e:elt)(e':elt')(e'':oee'), + lelistA (@ltk elt) (x,e) m -> + lelistA (@ltk elt') (x,e') m' -> + lelistA (@ltk oee') (x,e'') (combine m m'). +Proof. + induction m. + intros. + simpl. + exact (map_lelistA _ _ H0). + induction m'. + intros. + destruct a. + replace (combine ((t0, e0) :: m) nil) with + (map (fun e => (Some e,None (A:=elt'))) ((t0,e0)::m)); auto. + exact (map_lelistA _ _ H). + intros. + simpl. + destruct a as (k,e0); destruct a0 as (k',e0'). + destruct (X.compare k k'). + inversion_clear H; auto. + inversion_clear H; auto. + inversion_clear H0; auto. +Qed. +Hint Resolve combine_lelistA. + +Lemma combine_sorted : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), + sort (@ltk oee') (combine m m'). +Proof. + induction m. + intros; clear Hm. + simpl. + apply map_sorted; auto. + induction m'. + intros; clear Hm'. + destruct a. + replace (combine ((t0, e) :: m) nil) with + (map (fun e => (Some e,None (A:=elt'))) ((t0,e)::m)); auto. + apply map_sorted; auto. + intros. + simpl. + destruct a as (k,e); destruct a0 as (k',e'). + destruct (X.compare k k'). + inversion_clear Hm. + constructor; auto. + assert (lelistA (ltk (elt:=elt')) (k, e') ((k',e')::m')) by auto. + exact (combine_lelistA _ H0 H1). + inversion_clear Hm; inversion_clear Hm'. + constructor; auto. + assert (lelistA (ltk (elt:=elt')) (k, e') m') by apply Inf_eq with (k',e'); auto. + exact (combine_lelistA _ H0 H3). + inversion_clear Hm; inversion_clear Hm'. + constructor; auto. + change (lelistA (ltk (elt:=oee')) (k', (None, Some e')) + (combine ((k,e)::m) m')). + assert (lelistA (ltk (elt:=elt)) (k', e) ((k,e)::m)) by auto. + exact (combine_lelistA _ H3 H2). +Qed. + +Lemma map2_sorted : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m'), + sort (@ltk elt'') (map2 m m'). +Proof. + intros. + rewrite <- map2_alt_equiv. + unfold map2_alt. + assert (H0:=combine_sorted Hm Hm'). + set (l0:=combine m m') in *; clearbody l0. + set (f':= fun p : oee' => f (fst p) (snd p)). + assert (H1:=map_sorted (elt' := option elt'') H0 f'). + set (l1:=map f' l0) in *; clearbody l1. + clear f' f H0 l0 Hm Hm' m m'. + induction l1. + simpl; auto. + inversion_clear H1. + destruct a; destruct o; auto. + simpl. + constructor; auto. + clear IHl1. + induction l1. + simpl; auto. + destruct a; destruct o; simpl; auto. + inversion_clear H0; auto. + inversion_clear H0. + red in H1; simpl in H1. + inversion_clear H. + apply IHl1; auto. + apply Inf_lt with (t1, None (A:=elt'')); auto. +Qed. + +Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => Some (o,o') + end. + +Lemma combine_1 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), + find x (combine m m') = at_least_one (find x m) (find x m'). +Proof. + induction m. + intros. + simpl. + induction m'. + intros; simpl; auto. + simpl; destruct a. + simpl; destruct (X.compare x t0); simpl; auto. + inversion_clear Hm'; auto. + induction m'. + (* m' = nil *) + intros; destruct a; simpl. + destruct (X.compare x t0); simpl; auto. + inversion_clear Hm; clear H0 l Hm' IHm t0. + induction m; simpl; auto. + inversion_clear H. + destruct a. + simpl; destruct (X.compare x t0); simpl; auto. + (* m' <> nil *) + intros. + destruct a as (k,e); destruct a0 as (k',e'); simpl. + inversion Hm; inversion Hm'; subst. + destruct (X.compare k k'); simpl; + destruct (X.compare x k); + elim_comp || destruct (X.compare x k'); simpl; auto. + rewrite IHm; auto; simpl; elim_comp; auto. + rewrite IHm; auto; simpl; elim_comp; auto. + rewrite IHm; auto; simpl; elim_comp; auto. + change (find x (combine ((k, e) :: m) m') = at_least_one None (find x m')). + rewrite IHm'; auto. + simpl find; elim_comp; auto. + change (find x (combine ((k, e) :: m) m') = Some (Some e, find x m')). + rewrite IHm'; auto. + simpl find; elim_comp; auto. + change (find x (combine ((k, e) :: m) m') = + at_least_one (find x m) (find x m')). + rewrite IHm'; auto. + simpl find; elim_comp; auto. +Qed. + +Definition at_least_one_then_f (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => f o o' + end. + +Lemma map2_0 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m') (x:key), + find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). +Proof. + intros. + rewrite <- map2_alt_equiv. + unfold map2_alt. + assert (H:=combine_1 Hm Hm' x). + assert (H2:=combine_sorted Hm Hm'). + set (f':= fun p : oee' => f (fst p) (snd p)). + set (m0 := combine m m') in *; clearbody m0. + set (o:=find x m) in *; clearbody o. + set (o':=find x m') in *; clearbody o'. + clear Hm Hm' m m'. + generalize H; clear H. + match goal with |- ?m=?n -> ?p=?q => + assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end. + induction m0; simpl in *; intuition. + destruct o; destruct o'; simpl in *; try discriminate; auto. + destruct a as (k,(oo,oo')); simpl in *. + inversion_clear H2. + destruct (X.compare x k); simpl in *. + (* x < k *) + destruct (f' (oo,oo')); simpl. + elim_comp. + destruct o; destruct o'; simpl in *; try discriminate; auto. + destruct (IHm0 H0) as (H2,_); apply H2; auto. + rewrite <- H. + case_eq (find x m0); intros; auto. + assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). + red; auto. + destruct (Sort_Inf_NotIn H0 (Inf_lt H4 H1)). + exists p; apply find_2; auto. + (* x = k *) + assert (at_least_one_then_f o o' = f oo oo'). + destruct o; destruct o'; simpl in *; inversion_clear H; auto. + rewrite H2. + unfold f'; simpl. + destruct (f oo oo'); simpl. + elim_comp; auto. + destruct (IHm0 H0) as (_,H4); apply H4; auto. + case_eq (find x m0); intros; auto. + assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))). + red; auto. + destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)). + exists p; apply find_2; auto. + (* k < x *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + elim_comp; auto. + destruct (IHm0 H0) as (H3,_); apply H3; auto. + destruct (IHm0 H0) as (H3,_); apply H3; auto. + + (* None -> None *) + destruct a as (k,(oo,oo')). + simpl. + inversion_clear H2. + destruct (X.compare x k). + (* x < k *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + elim_comp; auto. + destruct (IHm0 H0) as (_,H4); apply H4; auto. + case_eq (find x m0); intros; auto. + assert (ltk (elt:=oee') (x,(oo,oo')) (k,(oo,oo'))). + red; auto. + destruct (Sort_Inf_NotIn H0 (Inf_lt H3 H1)). + exists p; apply find_2; auto. + (* x = k *) + discriminate. + (* k < x *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + elim_comp; auto. + destruct (IHm0 H0) as (_,H4); apply H4; auto. + destruct (IHm0 H0) as (_,H4); apply H4; auto. +Qed. + +(** Specification of [map2] *) + +Lemma map2_1 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), + In x m \/ In x m' -> + find x (map2 m m') = f (find x m) (find x m'). +Proof. + intros. + rewrite map2_0; auto. + destruct H as [(e,H)|(e,H)]. + rewrite (find_1 Hm H). + destruct (find x m'); simpl; auto. + rewrite (find_1 Hm' H). + destruct (find x m); simpl; auto. +Qed. + +Lemma map2_2 : + forall m (Hm : sort (@ltk elt) m) m' (Hm' : sort (@ltk elt') m')(x:key), + In x (map2 m m') -> In x m \/ In x m'. +Proof. + intros. + destruct H as (e,H). + generalize (map2_0 Hm Hm' x). + rewrite (find_1 (map2_sorted Hm Hm') H). + generalize (@find_2 _ m x). + generalize (@find_2 _ m' x). + destruct (find x m); + destruct (find x m'); simpl; intros. + left; exists e0; auto. + left; exists e0; auto. + right; exists e0; auto. + discriminate. +Qed. + +End Elt3. +End Raw. + +Module Make (X: OrderedType) <: S with Module E := X. +Module Raw := Raw X. +Module E := X. + +Definition key := X.t. + +Record slist (elt:Set) : Set := + {this :> Raw.t elt; sorted : sort (@Raw.PX.ltk elt) this}. +Definition t (elt:Set) := slist elt. + +Section Elt. + Variable elt elt' elt'':Set. + + Implicit Types m : t elt. + + Definition empty := Build_slist (Raw.empty_sorted elt). + Definition is_empty m := Raw.is_empty m.(this). + Definition add x e m := Build_slist (Raw.add_sorted m.(sorted) x e). + Definition find x m := Raw.find x m.(this). + Definition remove x m := Build_slist (Raw.remove_sorted m.(sorted) x). + Definition mem x m := Raw.mem x m.(this). + Definition map f m : t elt' := Build_slist (Raw.map_sorted m.(sorted) f). + Definition mapi f m : t elt' := Build_slist (Raw.mapi_sorted m.(sorted) f). + Definition map2 f m (m':t elt') : t elt'' := + Build_slist (Raw.map2_sorted f m.(sorted) m'.(sorted)). + Definition elements m := @Raw.elements elt m.(this). + Definition fold A f m i := @Raw.fold elt A f m.(this) i. + Definition equal cmp m m' := @Raw.equal elt cmp m.(this) m'.(this). + + Definition MapsTo x e m := Raw.PX.MapsTo x e m.(this). + Definition In x m := Raw.PX.In x m.(this). + Definition Empty m := Raw.Empty m.(this). + Definition Equal cmp m m' := @Raw.Equal elt cmp m.(this) m'.(this). + + Definition eq_key := Raw.PX.eqk. + Definition eq_key_elt := Raw.PX.eqke. + Definition lt_key := Raw.PX.ltk. + + Definition MapsTo_1 m := @Raw.PX.MapsTo_eq elt m.(this). + + Definition mem_1 m := @Raw.mem_1 elt m.(this) m.(sorted). + Definition mem_2 m := @Raw.mem_2 elt m.(this) m.(sorted). + + Definition empty_1 := @Raw.empty_1. + + Definition is_empty_1 m := @Raw.is_empty_1 elt m.(this). + Definition is_empty_2 m := @Raw.is_empty_2 elt m.(this). + + Definition add_1 m := @Raw.add_1 elt m.(this). + Definition add_2 m := @Raw.add_2 elt m.(this). + Definition add_3 m := @Raw.add_3 elt m.(this). + + Definition remove_1 m := @Raw.remove_1 elt m.(this) m.(sorted). + Definition remove_2 m := @Raw.remove_2 elt m.(this) m.(sorted). + Definition remove_3 m := @Raw.remove_3 elt m.(this) m.(sorted). + + Definition find_1 m := @Raw.find_1 elt m.(this) m.(sorted). + Definition find_2 m := @Raw.find_2 elt m.(this). + + Definition elements_1 m := @Raw.elements_1 elt m.(this). + Definition elements_2 m := @Raw.elements_2 elt m.(this). + Definition elements_3 m := @Raw.elements_3 elt m.(this) m.(sorted). + + Definition fold_1 m := @Raw.fold_1 elt m.(this). + + Definition map_1 m := @Raw.map_1 elt elt' m.(this). + Definition map_2 m := @Raw.map_2 elt elt' m.(this). + + Definition mapi_1 m := @Raw.mapi_1 elt elt' m.(this). + Definition mapi_2 m := @Raw.mapi_2 elt elt' m.(this). + + Definition map2_1 m (m':t elt') x f := + @Raw.map2_1 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x. + Definition map2_2 m (m':t elt') x f := + @Raw.map2_2 elt elt' elt'' f m.(this) m.(sorted) m'.(this) m'.(sorted) x. + + Definition equal_1 m m' := + @Raw.equal_1 elt m.(this) m.(sorted) m'.(this) m'.(sorted). + Definition equal_2 m m' := + @Raw.equal_2 elt m.(this) m.(sorted) m'.(this) m'.(sorted). + + End Elt. +End Make. + +Module Make_ord (X: OrderedType)(D : OrderedType) <: +Sord with Module Data := D + with Module MapS.E := X. + +Module Data := D. +Module MapS := Make(X). +Import MapS. + +Module MD := OrderedTypeFacts(D). +Import MD. + +Definition t := MapS.t D.t. + +Definition cmp e e' := match D.compare e e' with EQ _ => true | _ => false end. + +Fixpoint eq_list (m m' : list (X.t * D.t)) { struct m } : Prop := + match m, m' with + | nil, nil => True + | (x,e)::l, (x',e')::l' => + match X.compare x x' with + | EQ _ => D.eq e e' /\ eq_list l l' + | _ => False + end + | _, _ => False + end. + +Definition eq m m' := eq_list m.(this) m'.(this). + +Fixpoint lt_list (m m' : list (X.t * D.t)) {struct m} : Prop := + match m, m' with + | nil, nil => False + | nil, _ => True + | _, nil => False + | (x,e)::l, (x',e')::l' => + match X.compare x x' with + | LT _ => True + | GT _ => False + | EQ _ => D.lt e e' \/ (D.eq e e' /\ lt_list l l') + end + end. + +Definition lt m m' := lt_list m.(this) m'.(this). + +Lemma eq_equal : forall m m', eq m m' <-> equal cmp m m' = true. +Proof. + intros (l,Hl); induction l. + intros (l',Hl'); unfold eq; simpl. + destruct l'; unfold equal; simpl; intuition. + intros (l',Hl'); unfold eq. + destruct l'. + destruct a; unfold equal; simpl; intuition. + destruct a as (x,e). + destruct p as (x',e'). + unfold equal; simpl. + destruct (X.compare x x'); simpl; intuition. + unfold cmp at 1. + MD.elim_comp; clear H; simpl. + inversion_clear Hl. + inversion_clear Hl'. + destruct (IHl H (Build_slist H3)). + unfold equal, eq in H5; simpl in H5; auto. + destruct (andb_prop _ _ H); clear H. + generalize H0; unfold cmp. + MD.elim_comp; auto; intro; discriminate. + destruct (andb_prop _ _ H); clear H. + inversion_clear Hl. + inversion_clear Hl'. + destruct (IHl H (Build_slist H3)). + unfold equal, eq in H6; simpl in H6; auto. +Qed. + +Lemma eq_1 : forall m m', Equal cmp m m' -> eq m m'. +Proof. + intros. + generalize (@equal_1 D.t m m' cmp). + generalize (@eq_equal m m'). + intuition. +Qed. + +Lemma eq_2 : forall m m', eq m m' -> Equal cmp m m'. +Proof. + intros. + generalize (@equal_2 D.t m m' cmp). + generalize (@eq_equal m m'). + intuition. +Qed. + +Lemma eq_refl : forall m : t, eq m m. +Proof. + intros (m,Hm); induction m; unfold eq; simpl; auto. + destruct a. + destruct (X.compare t0 t0); auto. + apply (MapS.Raw.MX.lt_antirefl l); auto. + split. + apply D.eq_refl. + inversion_clear Hm. + apply (IHm H). + apply (MapS.Raw.MX.lt_antirefl l); auto. +Qed. + +Lemma eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1. +Proof. + intros (m,Hm); induction m; + intros (m', Hm'); destruct m'; unfold eq; simpl; + try destruct a as (x,e); try destruct p as (x',e'); auto. + destruct (X.compare x x'); MapS.Raw.MX.elim_comp; intuition. + inversion_clear Hm; inversion_clear Hm'. + apply (IHm H0 (Build_slist H4)); auto. +Qed. + +Lemma eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3. +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold eq; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); + try destruct p0 as (x'',e''); try contradiction; auto. + destruct (X.compare x x'); + 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. +Qed. + +Lemma lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3. +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + intros (m3, Hm3); destruct m3; unfold lt; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); + try destruct p0 as (x'',e''); try contradiction; auto. + destruct (X.compare x x'); + destruct (X.compare x' x''); + MapS.Raw.MX.elim_comp; auto. + intuition. + left; apply D.lt_trans with e'; auto. + left; apply lt_eq with e'; auto. + left; apply eq_lt with e'; auto. + right. + split. + apply D.eq_trans with e'; auto. + inversion_clear Hm1; inversion_clear Hm2; inversion_clear Hm3. + apply (IHm1 H2 (Build_slist H6) (Build_slist H8)); intuition. +Qed. + +Lemma lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2. +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; unfold eq, lt; simpl; + try destruct a as (x,e); + try destruct p as (x',e'); try contradiction; auto. + destruct (X.compare x x'); auto. + intuition. + exact (D.lt_not_eq H0 H1). + inversion_clear Hm1; inversion_clear Hm2. + apply (IHm1 H0 (Build_slist H5)); intuition. +Qed. + +Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto. + +Definition compare : forall m1 m2, Compare lt eq m1 m2. +Proof. + intros (m1,Hm1); induction m1; + intros (m2, Hm2); destruct m2; + [ apply EQ | apply LT | apply GT | ]; cmp_solve. + destruct a as (x,e); destruct p as (x',e'). + destruct (X.compare x x'); + [ apply LT | | apply GT ]; cmp_solve. + destruct (D.compare e e'); + [ apply LT | | apply GT ]; cmp_solve. + assert (Hm11 : sort (Raw.PX.ltk (elt:=D.t)) m1). + inversion_clear Hm1; auto. + assert (Hm22 : sort (Raw.PX.ltk (elt:=D.t)) m2). + inversion_clear Hm2; auto. + destruct (IHm1 Hm11 (Build_slist Hm22)); + [ apply LT | apply EQ | apply GT ]; cmp_solve. +Qed. + +End Make_ord. diff --git a/theories/FSets/FMapWeak.v b/theories/FSets/FMapWeak.v new file mode 100644 index 00000000..90ebeffc --- /dev/null +++ b/theories/FSets/FMapWeak.v @@ -0,0 +1,12 @@ +(***********************************************************************) +(* 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: FMapWeak.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +Require Export FMapWeakInterface. +Require Export FMapWeakList. diff --git a/theories/FSets/FMapWeakInterface.v b/theories/FSets/FMapWeakInterface.v new file mode 100644 index 00000000..b6df4da5 --- /dev/null +++ b/theories/FSets/FMapWeakInterface.v @@ -0,0 +1,201 @@ +(***********************************************************************) +(* 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: FMapWeakInterface.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +(** * Finite map library *) + +(** This file proposes an interface for finite maps over keys with decidable + equality, but no decidable order. *) + +Set Implicit Arguments. +Unset Strict Implicit. +Require Import FSetInterface. +Require Import FSetWeakInterface. + +Module Type S. + + Declare Module E : DecidableType. + + Definition key := E.t. + + Parameter t : Set -> Set. (** the abstract type of maps *) + + Section Types. + + Variable elt:Set. + + Parameter empty : t elt. + (** The empty map. *) + + Parameter is_empty : t elt -> bool. + (** Test whether a map is empty or not. *) + + Parameter add : key -> elt -> t elt -> t elt. + (** [add x y m] returns a map containing the same bindings as [m], + plus a binding of [x] to [y]. If [x] was already bound in [m], + its previous binding disappears. *) + + Parameter find : key -> t elt -> option elt. + (** [find x m] returns the current binding of [x] in [m], + or raises [Not_found] if no such binding exists. + NB: in Coq, the exception mechanism becomes a option type. *) + + Parameter remove : key -> t elt -> t elt. + (** [remove x m] returns a map containing the same bindings as [m], + except for [x] which is unbound in the returned map. *) + + Parameter mem : key -> t elt -> bool. + (** [mem x m] returns [true] if [m] contains a binding for [x], + and [false] otherwise. *) + + (** Coq comment: [iter] is useless in a purely functional world *) + (** val iter : (key -> 'a -> unit) -> 'a t -> unit *) + (** iter f m applies f to all bindings in map m. f receives the key as + first argument, and the associated value as second argument. + The bindings are passed to f in increasing order with respect to the + ordering over the type of the keys. Only current bindings are + presented to f: bindings hidden by more recent bindings are not + passed to f. *) + + Variable elt' : Set. + Variable elt'': Set. + + Parameter map : (elt -> elt') -> t elt -> t elt'. + (** [map f m] returns a map with same domain as [m], where the associated + value a of all bindings of [m] has been replaced by the result of the + application of [f] to [a]. The bindings are passed to [f] in + increasing order with respect to the ordering over the type of the + keys. *) + + Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'. + (** Same as [S.map], but the function receives as arguments both the + key and the associated value for each binding of the map. *) + + Parameter map2 : (option elt -> option elt' -> option elt'') -> t elt -> t elt' -> t elt''. + (** Not present in Ocaml. + [map 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). + (** Not present in Ocaml. + [elements m] returns an assoc list corresponding to the bindings of [m]. + Elements of this list are sorted with respect to their first components. + Useful to specify [fold] ... *) + + Parameter fold : forall A: Set, (key -> elt -> A -> A) -> t elt -> A -> A. + (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1] ... [kN] are the keys of all bindings in [m] + (in increasing order), and [d1] ... [dN] are the associated data. *) + + Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool. + (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, + that is, contain equal keys and associate them with equal data. + [cmp] is the equality predicate used to compare the data associated + with the keys. *) + + Section Spec. + + Variable m m' m'' : t elt. + Variable x y z : key. + Variable e e' : elt. + + Parameter MapsTo : key -> elt -> t elt -> Prop. + + Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m. + + Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m. + + Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p'). + + Definition eq_key_elt (p p':key*elt) := + E.eq (fst p) (fst p') /\ (snd p) = (snd p'). + + (** Specification of [MapsTo] *) + Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m. + + (** Specification of [mem] *) + Parameter mem_1 : In x m -> mem x m = true. + Parameter mem_2 : mem x m = true -> In x m. + + (** Specification of [empty] *) + Parameter empty_1 : Empty empty. + + (** Specification of [is_empty] *) + Parameter is_empty_1 : Empty m -> is_empty m = true. + Parameter is_empty_2 : is_empty m = true -> Empty m. + + (** Specification of [add] *) + Parameter add_1 : E.eq x y -> MapsTo y e (add x e m). + Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). + Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. + + (** Specification of [remove] *) + Parameter remove_1 : E.eq x y -> ~ In y (remove x m). + Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). + Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m. + + (** Specification of [find] *) + Parameter find_1 : MapsTo x e m -> find x m = Some e. + Parameter find_2 : find x m = Some e -> MapsTo x e m. + + (** Specification of [elements] *) + Parameter elements_1 : + MapsTo x e m -> InA eq_key_elt (x,e) (elements m). + Parameter elements_2 : + InA eq_key_elt (x,e) (elements m) -> MapsTo x e m. + Parameter elements_3 : NoDupA eq_key (elements m). + + (** Specification of [fold] *) + Parameter fold_1 : + forall (A : Set) (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. + + Definition Equal 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). + + Variable cmp : elt -> elt -> bool. + + (** Specification of [equal] *) + Parameter equal_1 : Equal cmp m m' -> equal cmp m m' = true. + Parameter equal_2 : equal cmp m m' = true -> Equal cmp m m'. + + End Spec. + End Types. + + (** Specification of [map] *) + Parameter map_1 : forall (elt elt':Set)(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':Set)(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':Set)(m: t elt)(x:key)(e:elt) + (f:key->elt->elt'), MapsTo x e m -> + exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m). + Parameter mapi_2 : forall (elt elt':Set)(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'':Set)(m: t elt)(m': t elt') + (x:key)(f:option elt->option elt'->option elt''), + In x m \/ In x m' -> + find x (map2 f m m') = f (find x m) (find x m'). + + Parameter map2_2 : forall (elt elt' elt'':Set)(m: t elt)(m': t elt') + (x:key)(f:option elt->option elt'->option elt''), + In x (map2 f m m') -> In x m \/ In x m'. + + Hint Immediate MapsTo_1 mem_2 is_empty_2. + + Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 add_3 remove_1 + remove_2 remove_3 find_1 find_2 fold_1 map_1 map_2 mapi_1 mapi_2. + +End S. diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v new file mode 100644 index 00000000..ce3893e0 --- /dev/null +++ b/theories/FSets/FMapWeakList.v @@ -0,0 +1,960 @@ +(***********************************************************************) +(* 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: FMapWeakList.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +(** * Finite map library *) + +(** This file proposes an implementation of the non-dependant interface + [FMapInterface.S] using lists of pairs, unordered but without redundancy. *) + +Require Import FSetInterface. +Require Import FSetWeakInterface. +Require Import FMapWeakInterface. + +Set Implicit Arguments. +Unset Strict Implicit. + +Arguments Scope list [type_scope]. + +Module Raw (X:DecidableType). + +Module PX := PairDecidableType X. +Import PX. + +Definition key := X.t. +Definition t (elt:Set) := list (X.t * elt). + +Section Elt. + +Variable elt : Set. + +(* now in PairDecidableType: +Definition eqk (p p':key*elt) := X.eq (fst p) (fst p'). +Definition eqke (p p':key*elt) := + X.eq (fst p) (fst p') /\ (snd p) = (snd p'). +*) + +Notation eqk := (eqk (elt:=elt)). +Notation eqke := (eqke (elt:=elt)). +Notation MapsTo := (MapsTo (elt:=elt)). +Notation In := (In (elt:=elt)). +Notation NoDupA := (NoDupA eqk). + +(** * [empty] *) + +Definition empty : t elt := nil. + +Definition Empty m := forall (a : key)(e:elt), ~ MapsTo a e m. + +Lemma empty_1 : Empty empty. +Proof. + unfold Empty,empty. + intros a e. + intro abs. + inversion abs. +Qed. + +Hint Resolve empty_1. + +Lemma empty_NoDup : NoDupA empty. +Proof. + unfold empty; auto. +Qed. + +(** * [is_empty] *) + +Definition is_empty (l : t elt) : bool := if l then true else false. + +Lemma is_empty_1 :forall m, Empty m -> is_empty m = true. +Proof. + unfold Empty, PX.MapsTo. + intros m. + case m;auto. + intros p l inlist. + destruct p. + absurd (InA eqke (t0, e) ((t0, e) :: l));auto. +Qed. + +Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. +Proof. + intros m. + case m;auto. + intros p l abs. + inversion abs. +Qed. + +(** * [mem] *) + +Fixpoint mem (k : key) (s : t elt) {struct s} : bool := + match s with + | nil => false + | (k',_) :: l => if X.eq_dec k k' then true else mem k l + end. + +Lemma mem_1 : forall m (Hm:NoDupA m) x, In x m -> mem x m = true. +Proof. + intros m Hm x; generalize Hm; clear Hm. + functional induction mem x m;intros NoDup belong1;trivial. + inversion belong1. inversion H. + inversion_clear NoDup. + inversion_clear belong1. + inversion_clear H3. + compute in H4; destruct H4. + elim H; auto. + apply H0; auto. + exists x; auto. +Qed. + +Lemma mem_2 : forall m (Hm:NoDupA m) x, mem x m = true -> In x m. +Proof. + intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. + functional induction mem x m; intros NoDup hyp; try discriminate. + exists e; auto. + inversion_clear NoDup. + destruct H0; auto. + exists x; auto. +Qed. + +(** * [find] *) + +Fixpoint find (k:key) (s: t elt) {struct s} : option elt := + match s with + | nil => None + | (k',x)::s' => if X.eq_dec k k' then Some x else find k s' + end. + +Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. +Proof. + intros m x. unfold PX.MapsTo. + functional induction find x m;simpl;intros e' eqfind; inversion eqfind; auto. +Qed. + +Lemma find_1 : forall m (Hm:NoDupA m) x e, + MapsTo x e m -> find x m = Some e. +Proof. + intros m Hm x e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction find x m;simpl; subst; try clear H_eq_1. + + inversion 2. + + do 2 inversion_clear 1. + compute in H3; destruct H3; subst; trivial. + elim H0; apply InA_eqk with (k,e); auto. + + do 2 inversion_clear 1; auto. + compute in H4; destruct H4; elim H; auto. +Qed. + +(* Not part of the exported specifications, used later for [combine]. *) + +Lemma find_eq : forall m (Hm:NoDupA m) x x', + X.eq x x' -> find x m = find x' m. +Proof. + induction m; simpl; auto; destruct a; intros. + inversion_clear Hm. + rewrite (IHm H1 x x'); auto. + destruct (X.eq_dec x t0); destruct (X.eq_dec x' t0); trivial. + elim n; apply X.eq_trans with x; auto. + elim n; apply X.eq_trans with x'; auto. +Qed. + +(** * [add] *) + +Fixpoint add (k : key) (x : elt) (s : t elt) {struct s} : t elt := + match s with + | nil => (k,x) :: nil + | (k',y) :: l => if X.eq_dec k k' then (k,x)::l else (k',y)::add k x l + end. + +Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). +Proof. + intros m x y e; generalize y; clear y; unfold PX.MapsTo. + functional induction add x e m;simpl;auto. +Qed. + +Lemma add_2 : forall m x y e e', + ~ X.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m). +Proof. + intros m x y e e'; generalize y e; clear y e; unfold PX.MapsTo. + functional induction add x e' m;simpl;auto. + intros y' e' eqky'; inversion_clear 1. + destruct H1; simpl in *. + elim eqky'; apply X.eq_trans with k'; auto. + auto. + intros y' e' eqky'; inversion_clear 1; intuition. +Qed. + +Lemma add_3 : forall m x y e e', + ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. +Proof. + intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. + functional induction add x e' m;simpl;auto. + intros; apply (In_inv_3 H0); auto. + constructor 2; apply (In_inv_3 H1); auto. + inversion_clear 2; auto. +Qed. + +Lemma add_3' : forall m x y e e', + ~ X.eq x y -> InA eqk (y,e) (add x e' m) -> InA eqk (y,e) m. +Proof. + intros m x y e e'. generalize y e; clear y e. + functional induction add x e' m;simpl;auto. + inversion_clear 2. + compute in H1; elim H; auto. + inversion H1. + constructor 2; inversion_clear H1; auto. + compute in H2; elim H0; auto. + inversion_clear 2; auto. +Qed. + +Lemma add_NoDup : forall m (Hm:NoDupA m) x e, NoDupA (add x e m). +Proof. + induction m. + simpl; constructor; auto; red; inversion 1. + intros. + destruct a as (x',e'). + simpl; case (X.eq_dec x x'); inversion_clear Hm; auto. + constructor; auto. + swap H. + apply InA_eqk with (x,e); auto. + constructor; auto. + swap H; apply add_3' with x e; auto. +Qed. + +(* Not part of the exported specifications, used later for [combine]. *) + +Lemma add_eq : forall m (Hm:NoDupA m) x a e, + X.eq x a -> find x (add a e m) = Some e. +Proof. + intros. + apply find_1; auto. + apply add_NoDup; auto. + apply add_1; auto. +Qed. + +Lemma add_not_eq : forall m (Hm:NoDupA m) x a e, + ~X.eq x a -> find x (add a e m) = find x m. +Proof. + intros. + case_eq (find x m); intros. + apply find_1; auto. + apply add_NoDup; auto. + apply add_2; auto. + apply find_2; auto. + case_eq (find x (add a e m)); intros; auto. + rewrite <- H0; symmetry. + apply find_1; auto. + apply add_3 with a e; auto. + apply find_2; auto. +Qed. + + +(** * [remove] *) + +Fixpoint remove (k : key) (s : t elt) {struct s} : t elt := + match s with + | nil => nil + | (k',x) :: l => if X.eq_dec k k' then l else (k',x) :: remove k l + end. + +Lemma remove_1 : forall m (Hm:NoDupA m) x y, X.eq x y -> ~ In y (remove x m). +Proof. + intros m Hm x y; generalize Hm; clear Hm. + functional induction remove x m;simpl;intros;auto. + + red; inversion 1; inversion H1. + + inversion_clear Hm. + subst. + swap H1. + destruct H3 as (e,H3); unfold PX.MapsTo in H3. + apply InA_eqk with (y,e); auto. + compute; apply X.eq_trans with k; auto. + + intro H2. + destruct H2 as (e,H2); inversion_clear H2. + compute in H3; destruct H3. + elim H; apply X.eq_trans with y; auto. + inversion_clear Hm. + elim (H0 H4 H1). + exists e; auto. +Qed. + +Lemma remove_2 : forall m (Hm:NoDupA m) x y e, + ~ X.eq x y -> MapsTo y e m -> MapsTo y e (remove x m). +Proof. + intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction remove x m;auto. + inversion_clear 3; auto. + compute in H2; destruct H2. + elim H0; apply X.eq_trans with k'; auto. + + inversion_clear 1; inversion_clear 2; auto. +Qed. + +Lemma remove_3 : forall m (Hm:NoDupA m) x y e, + MapsTo y e (remove x m) -> MapsTo y e m. +Proof. + intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction remove x m;auto. + do 2 inversion_clear 1; auto. +Qed. + +Lemma remove_3' : forall m (Hm:NoDupA m) x y e, + InA eqk (y,e) (remove x m) -> InA eqk (y,e) m. +Proof. + intros m Hm x y e; generalize Hm; clear Hm; unfold PX.MapsTo. + functional induction remove x m;auto. + do 2 inversion_clear 1; auto. +Qed. + +Lemma remove_NoDup : forall m (Hm:NoDupA m) x, NoDupA (remove x m). +Proof. + induction m. + simpl; intuition. + intros. + inversion_clear Hm. + destruct a as (x',e'). + simpl; case (X.eq_dec x x'); auto. + constructor; auto. + swap H; apply remove_3' with x; auto. +Qed. + +(** * [elements] *) + +Definition elements (m: t elt) := m. + +Lemma elements_1 : forall m x e, MapsTo x e m -> InA eqke (x,e) (elements m). +Proof. + auto. +Qed. + +Lemma elements_2 : forall m x e, InA eqke (x,e) (elements m) -> MapsTo x e m. +Proof. +auto. +Qed. + +Lemma elements_3 : forall m (Hm:NoDupA m), NoDupA (elements m). +Proof. + auto. +Qed. + +(** * [fold] *) + +Fixpoint fold (A:Set)(f:key->elt->A->A)(m:t elt) {struct m} : A -> A := + fun acc => + match m with + | nil => acc + | (k,e)::m' => fold f m' (f k e acc) + end. + +Lemma fold_1 : forall m (A:Set)(i:A)(f:key->elt->A->A), + fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i. +Proof. + intros; functional induction fold A f m i; auto. +Qed. + +(** * [equal] *) + +Definition check (cmp : elt -> elt -> bool)(k:key)(e:elt)(m': t elt) := + match find k m' with + | None => false + | Some e' => cmp e e' + end. + +Definition submap (cmp : elt -> elt -> bool)(m m' : t elt) : bool := + fold (fun k e b => andb (check cmp k e m') b) m true. + +Definition equal (cmp : elt -> elt -> bool)(m m' : t elt) : bool := + andb (submap cmp m m') (submap (fun e' e => cmp e e') m' m). + +Definition Submap cmp m m' := + (forall k, In k m -> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + +Definition Equal cmp m m' := + (forall k, In k m <-> In k m') /\ + (forall k e e', MapsTo k e m -> MapsTo k e' m' -> cmp e e' = true). + +Lemma submap_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + Submap cmp m m' -> submap cmp m m' = true. +Proof. + unfold Submap, submap. + induction m. + simpl; auto. + destruct a; simpl; intros. + destruct H. + inversion_clear Hm. + assert (H3 : In t0 m'). + apply H; exists e; auto. + destruct H3 as (e', H3). + unfold check at 2; rewrite (find_1 Hm' H3). + rewrite (H0 t0); simpl; auto. + eapply IHm; auto. + split; intuition. + apply H. + destruct H5 as (e'',H5); exists e''; auto. + apply H0 with k; auto. +Qed. + +Lemma submap_2 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + submap cmp m m' = true -> Submap cmp m m'. +Proof. + unfold Submap, submap. + induction m. + simpl; auto. + intuition. + destruct H0; inversion H0. + inversion H0. + + destruct a; simpl; intros. + inversion_clear Hm. + rewrite andb_b_true in H. + assert (check cmp t0 e m' = true). + clear H1 H0 Hm' IHm. + set (b:=check cmp t0 e m') in *. + generalize H; clear H; generalize b; clear b. + induction m; simpl; auto; intros. + destruct a; simpl in *. + destruct (andb_prop _ _ (IHm _ H)); auto. + rewrite H2 in H. + destruct (IHm H1 m' Hm' cmp H); auto. + unfold check in H2. + case_eq (find t0 m'); [intros e' H5 | intros H5]; + rewrite H5 in H2; try discriminate. + split; intros. + destruct H6 as (e0,H6); inversion_clear H6. + compute in H7; destruct H7; subst. + exists e'. + apply PX.MapsTo_eq with t0; auto. + apply find_2; auto. + apply H3. + exists e0; auto. + inversion_clear H6. + compute in H8; destruct H8; subst. + rewrite (find_1 Hm' (PX.MapsTo_eq H6 H7)) in H5; congruence. + apply H4 with k; auto. +Qed. + +(** Specification of [equal] *) + +Lemma equal_1 : forall m (Hm:NoDupA m) m' (Hm': NoDupA m') cmp, + Equal cmp m m' -> equal cmp m m' = true. +Proof. + unfold Equal, equal. + intuition. + apply andb_true_intro; split; apply submap_1; unfold Submap; firstorder. +Qed. + +Lemma equal_2 : forall m (Hm:NoDupA m) m' (Hm':NoDupA m') cmp, + equal cmp m m' = true -> Equal cmp m m'. +Proof. + unfold Equal, equal. + intros. + destruct (andb_prop _ _ H); clear H. + generalize (submap_2 Hm Hm' H0). + generalize (submap_2 Hm' Hm H1). + firstorder. +Qed. + +Variable elt':Set. + +(** * [map] and [mapi] *) + +Fixpoint map (f:elt -> elt') (m:t elt) {struct m} : 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' := + match m with + | nil => nil + | (k,e)::m' => (k,f k e) :: mapi f m' + end. + +End Elt. +Section Elt2. +(* A new section is necessary for previous definitions to work + with different [elt], especially [MapsTo]... *) + +Variable elt elt' : Set. + +(** Specification of [map] *) + +Lemma map_1 : forall (m:t elt)(x:key)(e:elt)(f:elt->elt'), + MapsTo x e m -> MapsTo x (f e) (map f m). +Proof. + intros m x e f. + (* functional induction map elt elt' f m. *) (* Marche pas ??? *) + induction m. + inversion 1. + + destruct a as (x',e'). + simpl. + inversion_clear 1. + constructor 1. + unfold eqke in *; simpl in *; intuition congruence. + constructor 2. + unfold MapsTo in *; auto. +Qed. + +Lemma map_2 : forall (m:t elt)(x:key)(f:elt->elt'), + In x (map f m) -> In x m. +Proof. + intros m x f. + (* functional induction map elt elt' f m. *) (* Marche pas ??? *) + induction m; simpl. + intros (e,abs). + inversion abs. + + destruct a as (x',e). + intros hyp. + inversion hyp. clear hyp. + inversion H; subst; rename x0 into e'. + exists e; constructor. + unfold eqke in *; simpl in *; intuition. + destruct IHm as (e'',hyp). + exists e'; auto. + exists e''. + constructor 2; auto. +Qed. + +Lemma map_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f:elt->elt'), + NoDupA (@eqk elt') (map f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm. + constructor; auto. + swap H. + (* il faut un map_1 avec eqk au lieu de eqke *) + clear IHm H0. + induction m; simpl in *; auto. + inversion H1. + destruct a; inversion H1; auto. +Qed. + +(** Specification of [mapi] *) + +Lemma mapi_1 : forall (m:t elt)(x:key)(e:elt)(f:key->elt->elt'), + MapsTo x e m -> + exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). +Proof. + intros m x e f. + (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) + induction m. + inversion 1. + + destruct a as (x',e'). + simpl. + inversion_clear 1. + exists x'. + destruct H0; simpl in *. + split; auto. + constructor 1. + unfold eqke in *; simpl in *; intuition congruence. + destruct IHm as (y, hyp); auto. + exists y; intuition. +Qed. + +Lemma mapi_2 : forall (m:t elt)(x:key)(f:key->elt->elt'), + In x (mapi f m) -> In x m. +Proof. + intros m x f. + (* functional induction mapi elt elt' f m. *) (* Marche pas ??? *) + induction m; simpl. + intros (e,abs). + inversion abs. + + destruct a as (x',e). + intros hyp. + inversion hyp. clear hyp. + inversion H; subst; rename x0 into e'. + exists e; constructor. + unfold eqke in *; simpl in *; intuition. + destruct IHm as (e'',hyp). + exists e'; auto. + exists e''. + constructor 2; auto. +Qed. + +Lemma mapi_NoDup : forall m (Hm : NoDupA (@eqk elt) m)(f: key->elt->elt'), + NoDupA (@eqk elt') (mapi f m). +Proof. + induction m; simpl; auto. + intros. + destruct a as (x',e'). + inversion_clear Hm; auto. + constructor; auto. + swap H. + clear IHm H0. + induction m; simpl in *; auto. + inversion_clear H1. + destruct a; inversion_clear H1; auto. +Qed. + +End Elt2. +Section Elt3. + +Variable elt elt' elt'' : Set. + +Notation oee' := (option elt * option elt')%type. + +Definition combine_l (m:t elt)(m':t elt') : t oee' := + mapi (fun k e => (Some e, find k m')) m. + +Definition combine_r (m:t elt)(m':t elt') : t oee' := + mapi (fun k e' => (find k m, Some e')) m'. + +Definition fold_right_pair (A B C:Set)(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 + 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), + NoDupA (eqk (elt:=oee')) (fold_right_pair (add (elt:=oee')) l r). +Proof. + induction l; simpl; auto. + destruct a; simpl; auto. + inversion_clear 1. + intros; apply add_NoDup; auto. +Qed. +Hint Resolve fold_right_pair_NoDup. + +Lemma combine_NoDup : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), + NoDupA (@eqk oee') (combine m m'). +Proof. + unfold combine, combine_r, combine_l. + intros. + set (f1 := fun (k : key) (e : elt) => (Some e, find k m')). + set (f2 := fun (k : key) (e' : elt') => (find k m, Some e')). + generalize (mapi_NoDup Hm f1). + generalize (mapi_NoDup Hm' f2). + set (l := mapi f1 m); clearbody l. + set (r := mapi f2 m'); clearbody r. + auto. +Qed. + +Definition at_least_left (o:option elt)(o':option elt') := + match o with + | None => None + | _ => Some (o,o') + end. + +Definition at_least_right (o:option elt)(o':option elt') := + match o' with + | None => None + | _ => Some (o,o') + end. + +Lemma combine_l_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine_l m m') = at_least_left (find x m) (find x m'). +Proof. + unfold combine_l. + intros. + case_eq (find x m); intros. + simpl. + apply find_1. + apply mapi_NoDup; auto. + destruct (mapi_1 (fun k e => (Some e, find k m')) (find_2 H)) as (y,(H0,H1)). + rewrite (find_eq Hm' (X.eq_sym H0)); auto. + simpl. + case_eq (find x (mapi (fun k e => (Some e, find k m')) m)); intros; auto. + destruct (@mapi_2 _ _ m x (fun k e => (Some e, find k m'))). + exists p; apply find_2; auto. + rewrite (find_1 Hm H1) in H; discriminate. +Qed. + +Lemma combine_r_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine_r m m') = at_least_right (find x m) (find x m'). +Proof. + unfold combine_r. + intros. + case_eq (find x m'); intros. + simpl. + apply find_1. + apply mapi_NoDup; auto. + destruct (mapi_1 (fun k e => (find k m, Some e)) (find_2 H)) as (y,(H0,H1)). + rewrite (find_eq Hm (X.eq_sym H0)); auto. + simpl. + case_eq (find x (mapi (fun k e' => (find k m, Some e')) m')); intros; auto. + destruct (@mapi_2 _ _ m' x (fun k e' => (find k m, Some e'))). + exists p; apply find_2; auto. + rewrite (find_1 Hm' H1) in H; discriminate. +Qed. + +Definition at_least_one (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => Some (o,o') + end. + +Lemma combine_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (combine m m') = at_least_one (find x m) (find x m'). +Proof. + unfold combine. + intros. + generalize (combine_r_1 Hm Hm' x). + generalize (combine_l_1 Hm Hm' x). + assert (NoDupA (eqk (elt:=oee')) (combine_l m m')). + unfold combine_l; apply mapi_NoDup; auto. + assert (NoDupA (eqk (elt:=oee')) (combine_r m m')). + unfold combine_r; apply mapi_NoDup; auto. + set (l := combine_l m m') in *; clearbody l. + set (r := combine_r m m') in *; clearbody r. + set (o := find x m); clearbody o. + set (o' := find x m'); clearbody o'. + clear Hm' Hm m m'. + induction l. + destruct o; destruct o'; simpl; intros; discriminate || auto. + destruct a; simpl in *; intros. + destruct (X.eq_dec x t0); simpl in *. + unfold at_least_left in H1. + destruct o; simpl in *; try discriminate. + inversion H1; subst. + apply add_eq; auto. + inversion_clear H; auto. + inversion_clear H. + rewrite <- IHl; auto. + apply add_not_eq; auto. +Qed. + +Variable f : option elt -> option elt' -> option elt''. + +Definition option_cons (A:Set)(k:key)(o:option A)(l:list (key*A)) := + match o with + | Some e => (k,e)::l + | None => l + end. + +Definition map2 m m' := + let m0 : t oee' := combine m m' in + let m1 : t (option elt'') := map (fun p => f (fst p) (snd p)) m0 in + fold_right_pair (option_cons (A:=elt'')) m1 nil. + +Lemma map2_NoDup : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m'), + NoDupA (@eqk elt'') (map2 m m'). +Proof. + intros. + unfold map2. + assert (H0:=combine_NoDup Hm Hm'). + set (l0:=combine m m') in *; clearbody l0. + set (f':= fun p : oee' => f (fst p) (snd p)). + assert (H1:=map_NoDup (elt' := option elt'') H0 f'). + set (l1:=map f' l0) in *; clearbody l1. + clear f' f H0 l0 Hm Hm' m m'. + induction l1. + simpl; auto. + inversion_clear H1. + destruct a; destruct o; simpl; auto. + constructor; auto. + swap H. + clear IHl1. + induction l1. + inversion H1. + inversion_clear H0. + destruct a; destruct o; simpl in *; auto. + inversion_clear H1; auto. +Qed. + +Definition at_least_one_then_f (o:option elt)(o':option elt') := + match o, o' with + | None, None => None + | _, _ => f o o' + end. + +Lemma map2_0 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + find x (map2 m m') = at_least_one_then_f (find x m) (find x m'). +Proof. + intros. + unfold map2. + assert (H:=combine_1 Hm Hm' x). + assert (H2:=combine_NoDup Hm Hm'). + set (f':= fun p : oee' => f (fst p) (snd p)). + set (m0 := combine m m') in *; clearbody m0. + set (o:=find x m) in *; clearbody o. + set (o':=find x m') in *; clearbody o'. + clear Hm Hm' m m'. + generalize H; clear H. + match goal with |- ?m=?n -> ?p=?q => + assert ((m=n->p=q)/\(m=None -> p=None)); [|intuition] end. + induction m0; simpl in *; intuition. + destruct o; destruct o'; simpl in *; try discriminate; auto. + destruct a as (k,(oo,oo')); simpl in *. + inversion_clear H2. + destruct (X.eq_dec x k); simpl in *. + (* x = k *) + assert (at_least_one_then_f o o' = f oo oo'). + destruct o; destruct o'; simpl in *; inversion_clear H; auto. + rewrite H2. + unfold f'; simpl. + destruct (f oo oo'); simpl. + destruct (X.eq_dec x k); try absurd_hyp 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). + (* k < x *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + destruct (X.eq_dec x k); [ absurd_hyp n; auto | auto]. + destruct (IHm0 H1) as (H3,_); apply H3; auto. + destruct (IHm0 H1) as (H3,_); apply H3; auto. + + (* None -> None *) + destruct a as (k,(oo,oo')). + simpl. + inversion_clear H2. + destruct (X.eq_dec x k). + (* x = k *) + discriminate. + (* k < x *) + unfold f'; simpl. + destruct (f oo oo'); simpl. + destruct (X.eq_dec x k); [ absurd_hyp n; auto | auto]. + destruct (IHm0 H1) as (_,H4); apply H4; auto. + destruct (IHm0 H1) as (_,H4); apply H4; auto. +Qed. + +(** Specification of [map2] *) +Lemma map2_1 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + In x m \/ In x m' -> + find x (map2 m m') = f (find x m) (find x m'). +Proof. + intros. + rewrite map2_0; auto. + destruct H as [(e,H)|(e,H)]. + rewrite (find_1 Hm H). + destruct (find x m'); simpl; auto. + rewrite (find_1 Hm' H). + destruct (find x m); simpl; auto. +Qed. + +Lemma map2_2 : + forall m (Hm:NoDupA (@eqk elt) m) m' (Hm':NoDupA (@eqk elt') m')(x:key), + In x (map2 m m') -> In x m \/ In x m'. +Proof. + intros. + destruct H as (e,H). + generalize (map2_0 Hm Hm' x). + rewrite (find_1 (map2_NoDup Hm Hm') H). + generalize (@find_2 _ m x). + generalize (@find_2 _ m' x). + destruct (find x m); + destruct (find x m'); simpl; intros. + left; exists e0; auto. + left; exists e0; auto. + right; exists e0; auto. + discriminate. +Qed. + +End Elt3. +End Raw. + + +Module Make (X: DecidableType) <: S with Module E:=X. + Module Raw := Raw X. + + Module E := X. + Definition key := X.t. + + Record slist (elt:Set) : Set := + {this :> Raw.t elt; NoDup : NoDupA (@Raw.PX.eqk elt) this}. + Definition t (elt:Set) := slist elt. + + Section Elt. + Variable elt elt' elt'':Set. + + Implicit Types m : t elt. + + Definition empty := Build_slist (Raw.empty_NoDup elt). + Definition is_empty m := Raw.is_empty m.(this). + Definition add x e m := Build_slist (Raw.add_NoDup m.(NoDup) x e). + Definition find x m := Raw.find x m.(this). + Definition remove x m := Build_slist (Raw.remove_NoDup m.(NoDup) x). + Definition mem x m := Raw.mem x m.(this). + Definition map f m : t elt' := Build_slist (Raw.map_NoDup m.(NoDup) f). + Definition mapi f m : t elt' := Build_slist (Raw.mapi_NoDup m.(NoDup) f). + Definition map2 f m (m':t elt') : t elt'' := + Build_slist (Raw.map2_NoDup f m.(NoDup) m'.(NoDup)). + Definition elements m := @Raw.elements elt m.(this). + Definition fold A f m i := @Raw.fold elt A f m.(this) i. + Definition equal cmp m m' := @Raw.equal elt cmp m.(this) m'.(this). + + Definition MapsTo x e m := Raw.PX.MapsTo x e m.(this). + Definition In x m := Raw.PX.In x m.(this). + Definition Empty m := Raw.Empty m.(this). + Definition Equal cmp m m' := @Raw.Equal elt cmp m.(this) m'.(this). + + Definition eq_key (p p':key*elt) := X.eq (fst p) (fst p'). + + Definition eq_key_elt (p p':key*elt) := + X.eq (fst p) (fst p') /\ (snd p) = (snd p'). + + Definition MapsTo_1 m := @Raw.PX.MapsTo_eq elt m.(this). + + Definition mem_1 m := @Raw.mem_1 elt m.(this) m.(NoDup). + Definition mem_2 m := @Raw.mem_2 elt m.(this) m.(NoDup). + + Definition empty_1 := @Raw.empty_1. + + Definition is_empty_1 m := @Raw.is_empty_1 elt m.(this). + Definition is_empty_2 m := @Raw.is_empty_2 elt m.(this). + + Definition add_1 m := @Raw.add_1 elt m.(this). + Definition add_2 m := @Raw.add_2 elt m.(this). + Definition add_3 m := @Raw.add_3 elt m.(this). + + Definition remove_1 m := @Raw.remove_1 elt m.(this) m.(NoDup). + Definition remove_2 m := @Raw.remove_2 elt m.(this) m.(NoDup). + Definition remove_3 m := @Raw.remove_3 elt m.(this) m.(NoDup). + + Definition find_1 m := @Raw.find_1 elt m.(this) m.(NoDup). + Definition find_2 m := @Raw.find_2 elt m.(this). + + Definition elements_1 m := @Raw.elements_1 elt m.(this). + Definition elements_2 m := @Raw.elements_2 elt m.(this). + Definition elements_3 m := @Raw.elements_3 elt m.(this) m.(NoDup). + + Definition fold_1 m := @Raw.fold_1 elt m.(this). + + Definition map_1 m := @Raw.map_1 elt elt' m.(this). + Definition map_2 m := @Raw.map_2 elt elt' m.(this). + + Definition mapi_1 m := @Raw.mapi_1 elt elt' m.(this). + Definition mapi_2 m := @Raw.mapi_2 elt elt' m.(this). + + Definition map2_1 m (m':t elt') x f := + @Raw.map2_1 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x. + Definition map2_2 m (m':t elt') x f := + @Raw.map2_2 elt elt' elt'' f m.(this) m.(NoDup) m'.(this) m'.(NoDup) x. + + Definition equal_1 m m' := @Raw.equal_1 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup). + Definition equal_2 m m' := @Raw.equal_2 elt m.(this) m.(NoDup) m'.(this) m'.(NoDup). + + End Elt. +End Make. + + diff --git a/theories/FSets/FMaps.v b/theories/FSets/FMaps.v new file mode 100644 index 00000000..ae5b86c9 --- /dev/null +++ b/theories/FSets/FMaps.v @@ -0,0 +1,12 @@ +(***********************************************************************) +(* 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: FMaps.v 8667 2006-03-28 11:59:44Z letouzey $ *) + +Require Export FMapInterface. +Require Export FMapList. diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v new file mode 100644 index 00000000..3ea50df8 --- /dev/null +++ b/theories/FSets/FSetBridge.v @@ -0,0 +1,750 @@ +(***********************************************************************) +(* 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: FSetBridge.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +(** * Finite sets library *) + +(** This module implements bridges (as functors) from dependent + to/from non-dependent set signature. *) + +Require Export FSetInterface. +Set Implicit Arguments. +Unset Strict Implicit. +Set Firstorder Depth 2. + +(** * From non-dependent signature [S] to dependent signature [Sdep]. *) + +Module DepOfNodep (M: S) <: Sdep with Module E := M.E. + Import M. + + Module ME := OrderedTypeFacts E. + + Definition empty : {s : t | Empty s}. + Proof. + exists empty; auto. + Qed. + + Definition is_empty : forall s : t, {Empty s} + {~ Empty s}. + Proof. + intros; generalize (is_empty_1 (s:=s)) (is_empty_2 (s:=s)). + case (is_empty s); intuition. + Qed. + + + Definition mem : forall (x : elt) (s : t), {In x s} + {~ In x s}. + Proof. + intros; generalize (mem_1 (s:=s) (x:=x)) (mem_2 (s:=s) (x:=x)). + case (mem x s); intuition. + Qed. + + Definition Add (x : elt) (s s' : t) := + forall y : elt, In y s' <-> E.eq x y \/ In y s. + + Definition add : forall (x : elt) (s : t), {s' : t | Add x s s'}. + Proof. + intros; exists (add x s); auto. + unfold Add in |- *; intuition. + elim (ME.eq_dec x y); auto. + intros; right. + eapply add_3; eauto. + Qed. + + Definition singleton : + forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. + Proof. + intros; exists (singleton x); intuition. + Qed. + + Definition remove : + forall (x : elt) (s : t), + {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. + Proof. + intros; exists (remove x s); intuition. + absurd (In x (remove x s)); auto. + apply In_1 with y; auto. + elim (ME.eq_dec x y); intros; auto. + absurd (In x (remove x s)); auto. + apply In_1 with y; auto. + eauto. + Qed. + + Definition union : + forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}. + Proof. + intros; exists (union s s'); intuition. + Qed. + + Definition inter : + forall s s' : t, {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}. + Proof. + intros; exists (inter s s'); intuition; eauto. + 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. + absurd (In x s'); eauto. + Qed. + + Definition equal : forall s s' : t, {Equal s s'} + {~ Equal s s'}. + Proof. + intros. + generalize (equal_1 (s:=s) (s':=s')) (equal_2 (s:=s) (s':=s')). + case (equal s s'); intuition. + Qed. + + Definition subset : forall s s' : t, {Subset s s'} + {~Subset s s'}. + Proof. + intros. + generalize (subset_1 (s:=s) (s':=s')) (subset_2 (s:=s) (s':=s')). + case (subset s s'); intuition. + Qed. + + Definition elements : + forall s : t, + {l : list elt | ME.Sort l /\ (forall x : elt, In x s <-> ME.In x l)}. + Proof. + intros; exists (elements s); intuition. + Defined. + + Definition fold : + forall (A : Set) (f : elt -> A -> A) (s : t) (i : A), + {r : A | let (l,_) := elements s in + r = fold_left (fun a e => f e a) l i}. + Proof. + intros; exists (fold (A:=A) f s i); exact (fold_1 s i f). + Qed. + + Definition cardinal : + forall s : t, + {r : nat | let (l,_) := elements s in r = length l }. + Proof. + intros; exists (cardinal s); exact (cardinal_1 s). + Qed. + + Definition fdec (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) + (x : elt) := if Pdec x then true else false. + + Lemma compat_P_aux : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}), + compat_P E.eq P -> compat_bool E.eq (fdec Pdec). + Proof. + unfold compat_P, compat_bool, fdec in |- *; intros. + generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder. + Qed. + + Hint Resolve compat_P_aux. + + Definition filter : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), + {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}. + Proof. + intros. + exists (filter (fdec Pdec) s). + intro H; assert (compat_bool E.eq (fdec Pdec)); auto. + intuition. + eauto. + generalize (filter_2 H0 H1). + unfold fdec in |- *. + case (Pdec x); intuition. + inversion H2. + apply filter_3; auto. + unfold fdec in |- *; simpl in |- *. + case (Pdec x); intuition. + Qed. + + Definition for_all : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), + {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. + Proof. + intros. + generalize (for_all_1 (s:=s) (f:=fdec Pdec)) + (for_all_2 (s:=s) (f:=fdec Pdec)). + case (for_all (fdec Pdec) s); unfold For_all in |- *; [ left | right ]; + intros. + assert (compat_bool E.eq (fdec Pdec)); auto. + generalize (H0 H3 (refl_equal _) _ H2). + unfold fdec in |- *. + case (Pdec x); intuition. + inversion H4. + intuition. + absurd (false = true); [ auto with bool | apply H; auto ]. + intro. + 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. + 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 ]; + intros. + elim H0; auto; intros. + exists x; intuition. + generalize H4. + unfold fdec in |- *. + case (Pdec x); intuition. + inversion H2. + intuition. + elim H2; intros. + absurd (false = true); [ auto with bool | apply H; auto ]. + exists x; intuition. + unfold fdec in |- *. + case (Pdec x); intuition. + Qed. + + Definition partition : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) (s : t), + {partition : t * t | + let (s1, s2) := partition in + compat_P E.eq P -> + For_all P s1 /\ + For_all (fun x => ~ P x) s2 /\ + (forall x : elt, In x s <-> In x s1 \/ In x s2)}. + Proof. + intros. + exists (partition (fdec Pdec) s). + generalize (partition_1 s (f:=fdec Pdec)) (partition_2 s (f:=fdec Pdec)). + case (partition (fdec Pdec) s). + intros s1 s2; simpl 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; + apply (f_equal negb); auto. + intuition. + generalize H4; unfold For_all, Equal in |- *; intuition. + elim (H0 x); intros. + assert (fdec Pdec x = true). + eauto. + generalize H8; unfold fdec in |- *; case (Pdec x); intuition. + inversion H9. + generalize H; unfold For_all, Equal in |- *; intuition. + elim (H0 x); intros. + 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 |- *; + [ left | right ]. + elim (H4 x); intros _ B; apply B; auto. + elim (H x); intros _ B; apply B; auto. + apply filter_3; auto. + rewrite H5; auto. + eapply (filter_1 (s:=s) (x:=x) H2); elim (H4 x); intros B _; apply B; + auto. + eapply (filter_1 (s:=s) (x:=x) H3); elim (H x); intros B _; apply B; auto. + Qed. + + Definition choose : forall s : t, {x : elt | In x s} + {Empty s}. + Proof. + intros. + generalize (choose_1 (s:=s)) (choose_2 (s:=s)). + case (choose s); [ left | right ]; auto. + exists e; auto. + Qed. + + Definition min_elt : + forall s : t, + {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}. + Proof. + intros; + generalize (min_elt_1 (s:=s)) (min_elt_2 (s:=s)) (min_elt_3 (s:=s)). + case (min_elt s); [ left | right ]; auto. + exists e; unfold For_all in |- *; eauto. + Qed. + + Definition max_elt : + forall s : t, + {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}. + Proof. + intros; + generalize (max_elt_1 (s:=s)) (max_elt_2 (s:=s)) (max_elt_3 (s:=s)). + case (max_elt s); [ left | right ]; auto. + exists e; unfold For_all in |- *; eauto. + Qed. + + Module E := E. + + Definition elt := elt. + Definition t := t. + + Definition In := In. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) (s : t) := + forall x : elt, In x s -> P x. + Definition Exists (P : elt -> Prop) (s : t) := + exists x : elt, In x s /\ P x. + + Definition eq_In := In_1. + + Definition eq := Equal. + Definition lt := lt. + Definition eq_refl := eq_refl. + Definition eq_sym := eq_sym. + Definition eq_trans := eq_trans. + Definition lt_trans := lt_trans. + Definition lt_not_eq := lt_not_eq. + Definition compare := compare. + +End DepOfNodep. + + +(** * From dependent signature [Sdep] to non-dependent signature [S]. *) + +Module NodepOfDep (M: Sdep) <: S with Module E := M.E. + Import M. + + Module ME := OrderedTypeFacts E. + + Definition empty : t := let (s, _) := empty in s. + + Lemma empty_1 : Empty empty. + Proof. + unfold empty in |- *; case M.empty; auto. + Qed. + + Definition is_empty (s : t) : bool := + if is_empty s then true else false. + + Lemma is_empty_1 : forall s : t, Empty s -> is_empty s = true. + Proof. + intros; unfold is_empty in |- *; case (M.is_empty s); auto. + Qed. + + Lemma is_empty_2 : forall s : t, is_empty s = true -> Empty s. + Proof. + intro s; unfold is_empty in |- *; case (M.is_empty s); auto. + intros; discriminate H. + Qed. + + Definition mem (x : elt) (s : t) : bool := + if mem x s then true else false. + + Lemma mem_1 : forall (s : t) (x : elt), In x s -> mem x s = true. + Proof. + intros; unfold mem 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. + intros; discriminate H. + Qed. + + Definition equal (s s' : t) : bool := + if equal s s' then true else false. + + Lemma equal_1 : forall s s' : t, Equal s s' -> equal s s' = true. + Proof. + intros; unfold equal in |- *; case M.equal; intuition. + Qed. + + Lemma equal_2 : forall s s' : t, equal s s' = true -> Equal s s'. + Proof. + intros s s'; unfold equal 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. + intros; unfold subset in |- *; case M.subset; intuition. + Qed. + + Lemma subset_2 : forall s s' : t, subset s s' = true -> Subset s s'. + Proof. + intros s s'; unfold subset in |- *; case (M.subset s s'); intuition; + inversion H. + Qed. + + Definition choose (s : t) : option elt := + match choose s with + | inleft (exist x _) => Some x + | inright _ => None + end. + + Lemma choose_1 : forall (s : t) (x : elt), choose s = Some x -> In x s. + Proof. + intros s x; unfold choose in |- *; case (M.choose s). + simple destruct s0; intros; injection H; intros; subst; auto. + intros; discriminate H. + Qed. + + Lemma choose_2 : forall s : t, choose s = None -> Empty s. + Proof. + intro s; unfold choose in |- *; case (M.choose s); auto. + simple destruct s0; intros; discriminate H. + Qed. + + Definition elements (s : t) : list elt := let (l, _) := elements s in l. + + Lemma elements_1 : forall (s : t) (x : elt), In x s -> ME.In x (elements s). + Proof. + intros; unfold elements in |- *; case (M.elements s); firstorder. + Qed. + + Lemma elements_2 : forall (s : t) (x : elt), ME.In x (elements s) -> In x s. + Proof. + intros s x; unfold elements in |- *; case (M.elements s); firstorder. + Qed. + + Lemma elements_3 : forall s : t, ME.Sort (elements s). + Proof. + intros; unfold elements in |- *; case (M.elements s); firstorder. + Qed. + + Definition min_elt (s : t) : option elt := + match min_elt s with + | inleft (exist x _) => Some x + | inright _ => None + end. + + Lemma min_elt_1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. + Proof. + intros s x; unfold min_elt in |- *; case (M.min_elt s). + simple destruct s0; intros; injection H; intros; subst; intuition. + intros; discriminate H. + Qed. + + Lemma min_elt_2 : + forall (s : t) (x y : elt), min_elt s = Some x -> In y s -> ~ E.lt y x. + Proof. + intros s x y; unfold min_elt in |- *; case (M.min_elt s). + unfold For_all in |- *; simple destruct s0; intros; injection H; intros; + subst; firstorder. + intros; discriminate H. + Qed. + + Lemma min_elt_3 : forall s : t, min_elt s = None -> Empty s. + Proof. + intros s; unfold min_elt in |- *; case (M.min_elt s); auto. + simple destruct s0; intros; discriminate H. + Qed. + + Definition max_elt (s : t) : option elt := + match max_elt s with + | inleft (exist x _) => Some x + | inright _ => None + end. + + Lemma max_elt_1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. + Proof. + intros s x; unfold max_elt in |- *; case (M.max_elt s). + simple destruct s0; intros; injection H; intros; subst; intuition. + intros; discriminate H. + Qed. + + Lemma max_elt_2 : + forall (s : t) (x y : elt), max_elt s = Some x -> In y s -> ~ E.lt x y. + Proof. + intros s x y; unfold max_elt in |- *; case (M.max_elt s). + unfold For_all in |- *; simple destruct s0; intros; injection H; intros; + subst; firstorder. + intros; discriminate H. + Qed. + + Lemma max_elt_3 : forall s : t, max_elt s = None -> Empty s. + Proof. + intros s; unfold max_elt in |- *; case (M.max_elt s); auto. + simple destruct s0; intros; discriminate H. + Qed. + + Definition add (x : elt) (s : t) : t := let (s', _) := add x s in s'. + + Lemma add_1 : forall (s : t) (x y : elt), E.eq x y -> In y (add x s). + Proof. + intros; unfold add in |- *; case (M.add x s); unfold Add in |- *; + firstorder. + Qed. + + Lemma add_2 : forall (s : t) (x y : elt), In y s -> In y (add x s). + Proof. + intros; unfold add in |- *; case (M.add x s); unfold Add in |- *; + firstorder. + Qed. + + Lemma add_3 : + forall (s : t) (x y : elt), ~ E.eq x y -> In y (add x s) -> In y s. + Proof. + intros s x y; unfold add in |- *; case (M.add x s); unfold Add in |- *; + firstorder. + Qed. + + Definition remove (x : elt) (s : t) : t := let (s', _) := remove x s in s'. + + Lemma remove_1 : forall (s : t) (x y : elt), E.eq x y -> ~ In y (remove x s). + Proof. + intros; unfold remove in |- *; case (M.remove x s); firstorder. + Qed. + + Lemma remove_2 : + forall (s : t) (x y : elt), ~ E.eq x y -> In y s -> In y (remove x s). + Proof. + intros; unfold remove in |- *; case (M.remove x s); firstorder. + Qed. + + Lemma remove_3 : forall (s : t) (x y : elt), In y (remove x s) -> In y s. + Proof. + intros s x y; unfold remove 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. + 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). + 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. + 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. + 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. + 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. + 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. + 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. + 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. + 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. + 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. + intros s s' x; unfold diff in |- *; case (M.diff s s'); firstorder. + Qed. + + Definition cardinal (s : t) : nat := let (f, _) := cardinal s in f. + + Lemma cardinal_1 : forall s, cardinal s = length (elements s). + Proof. + intros; unfold cardinal in |- *; case (M.cardinal s); unfold elements in *; + destruct (M.elements s); auto. + Qed. + + Definition fold (B : Set) (f : elt -> B -> B) (i : t) + (s : B) : B := let (fold, _) := fold f i s in fold. + + Lemma fold_1 : + forall (s : t) (A : Set) (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 *; + destruct (M.elements s); auto. + Qed. + + Definition f_dec : + forall (f : elt -> bool) (x : elt), {f x = true} + {f x <> true}. + Proof. + intros; case (f x); auto with bool. + Defined. + + Lemma compat_P_aux : + forall f : elt -> bool, + compat_bool E.eq f -> compat_P E.eq (fun x => f x = true). + Proof. + unfold compat_bool, compat_P in |- *; 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'. + + Lemma filter_1 : + forall (s : t) (x : elt) (f : elt -> bool), + compat_bool E.eq f -> In x (filter f s) -> In x s. + Proof. + intros s x f; unfold filter in |- *; case M.filter; intuition. + generalize (i (compat_P_aux H)); firstorder. + Qed. + + Lemma filter_2 : + forall (s : t) (x : elt) (f : elt -> bool), + compat_bool E.eq f -> In x (filter f s) -> f x = true. + Proof. + intros s x f; unfold filter in |- *; case M.filter; intuition. + generalize (i (compat_P_aux H)); firstorder. + Qed. + + Lemma filter_3 : + forall (s : t) (x : elt) (f : elt -> bool), + compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). + Proof. + intros s x f; unfold filter in |- *; case M.filter; intuition. + generalize (i (compat_P_aux H)); firstorder. + Qed. + + Definition for_all (f : elt -> bool) (s : t) : bool := + if for_all (P:=fun x => f x = true) (f_dec f) s + then true + else false. + + Lemma for_all_1 : + forall (s : t) (f : elt -> bool), + compat_bool E.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true. + Proof. + intros s f; unfold for_all 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. + 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. + + Lemma exists_1 : + forall (s : t) (f : elt -> bool), + compat_bool E.eq f -> Exists (fun x => f x = true) s -> exists_ f s = true. + Proof. + intros s f; unfold exists_ 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. + intros s f; unfold exists_ in |- *; case M.exists_; intuition; + inversion H0. + Qed. + + Definition partition (f : elt -> bool) (s : t) : + t * t := + let (p, _) := partition (P:=fun x => f x = true) (f_dec f) s in p. + + Lemma partition_1 : + forall (s : t) (f : elt -> bool), + compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). + Proof. + intros s f; unfold partition 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). + eapply filter_1; eauto. + elim H3; intros; auto. + absurd (f a = true). + exact (H a H6). + eapply filter_2; eauto. + Qed. + + Lemma partition_2 : + forall (s : t) (f : elt -> bool), + compat_bool E.eq f -> Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. + intros s f; unfold partition 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); + auto. + simpl in |- *; unfold Equal in |- *; intuition. + apply filter_3; firstorder. + elim (H2 a); intros. + assert (In a s). + eapply filter_1; eauto. + elim H3; intros; auto. + absurd (f a = true). + intro. + generalize (filter_2 D H1). + rewrite H7; intros H8; inversion H8. + exact (H0 a H6). + Qed. + + + Module E := E. + Definition elt := elt. + Definition t := t. + + Definition In := In. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Add (x : elt) (s s' : t) := + forall y : elt, In y s' <-> E.eq y x \/ In y s. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) (s : t) := + forall x : elt, In x s -> P x. + Definition Exists (P : elt -> Prop) (s : t) := + exists x : elt, In x s /\ P x. + + Definition In_1 := eq_In. + + Definition eq := Equal. + Definition lt := lt. + Definition eq_refl := eq_refl. + Definition eq_sym := eq_sym. + Definition eq_trans := eq_trans. + Definition lt_trans := lt_trans. + Definition lt_not_eq := lt_not_eq. + Definition compare := compare. + +End NodepOfDep. diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v new file mode 100644 index 00000000..006d78c7 --- /dev/null +++ b/theories/FSets/FSetEqProperties.v @@ -0,0 +1,923 @@ +(***********************************************************************) +(* 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: FSetEqProperties.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +(** * Finite sets library *) + +(** This module proves many properties of finite sets that + are consequences of the axiomatization in [FsetInterface] + Contrary to the functor in [FsetProperties] it uses + sets operations instead of predicates over sets, i.e. + [mem x s=true] instead of [In x s], + [equal s s'=true] instead of [Equal s s'], etc. *) + + +Require Import FSetProperties. +Require Import Zerob. +Require Import Sumbool. +Require Import Omega. + +Module EqProperties (M:S). +Import M. +Import Logic. (* to unmask [eq] *) +Import Peano. (* to unmask [lt] *) + +Module ME := OrderedTypeFacts E. +Module MP := Properties M. +Import MP. +Import MP.FM. + +Definition Add := MP.Add. + +Section BasicProperties. + +(** Some old specifications written with boolean equalities. *) + +Variable s s' s'': t. +Variable x y z : elt. + +Lemma mem_eq: + E.eq x y -> mem x s=mem y s. +Proof. +intro H; rewrite H; auto. +Qed. + +Lemma equal_mem_1: + (forall a, mem a s=mem a s') -> equal s s'=true. +Proof. +intros; apply equal_1; unfold Equal; intros. +do 2 rewrite mem_iff; rewrite H; tauto. +Qed. + +Lemma equal_mem_2: + equal s s'=true -> forall a, mem a s=mem a s'. +Proof. +intros; rewrite (equal_2 H); auto. +Qed. + +Lemma subset_mem_1: + (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. +Proof. +intros; apply subset_1; unfold Subset; intros a. +do 2 rewrite mem_iff; auto. +Qed. + +Lemma subset_mem_2: + subset s s'=true -> forall a, mem a s=true -> mem a s'=true. +Proof. +intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. +Qed. + +Lemma empty_mem: mem x empty=false. +Proof. +rewrite <- not_mem_iff; auto. +Qed. + +Lemma is_empty_equal_empty: is_empty s = equal s empty. +Proof. +apply bool_1; split; intros. +rewrite <- (empty_is_empty_1 (s:=empty)); auto with set. +rewrite <- is_empty_iff; auto with set. +Qed. + +Lemma choose_mem_1: choose s=Some x -> mem x s=true. +Proof. +auto. +Qed. + +Lemma choose_mem_2: choose s=None -> is_empty s=true. +Proof. +auto. +Qed. + +Lemma add_mem_1: mem x (add x s)=true. +Proof. +auto. +Qed. + +Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. +Proof. +apply add_neq_b. +Qed. + +Lemma remove_mem_1: mem x (remove x s)=false. +Proof. +rewrite <- not_mem_iff; auto. +Qed. + +Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. +Proof. +apply remove_neq_b. +Qed. + +Lemma singleton_equal_add: + equal (singleton x) (add x empty)=true. +Proof. +rewrite (singleton_equal_add x); auto with set. +Qed. + +Lemma union_mem: + mem x (union s s')=mem x s || mem x s'. +Proof. +apply union_b. +Qed. + +Lemma inter_mem: + mem x (inter s s')=mem x s && mem x s'. +Proof. +apply inter_b. +Qed. + +Lemma diff_mem: + mem x (diff s s')=mem x s && negb (mem x s'). +Proof. +apply diff_b. +Qed. + +(** properties of [mem] *) + +Lemma mem_3 : ~In x s -> mem x s=false. +Proof. +intros; rewrite <- not_mem_iff; auto. +Qed. + +Lemma mem_4 : mem x s=false -> ~In x s. +Proof. +intros; rewrite not_mem_iff; auto. +Qed. + +(** Properties of [equal] *) + +Lemma equal_refl: equal s s=true. +Proof. +auto with set. +Qed. + +Lemma equal_sym: equal s s'=equal s' s. +Proof. +intros; apply bool_1; do 2 rewrite <- equal_iff; intuition. +Qed. + +Lemma equal_trans: + equal s s'=true -> equal s' s''=true -> equal s s''=true. +Proof. +intros; rewrite (equal_2 H); auto. +Qed. + +Lemma equal_equal: + equal s s'=true -> equal s s''=equal s' s''. +Proof. +intros; rewrite (equal_2 H); auto. +Qed. + +Lemma equal_cardinal: + equal s s'=true -> cardinal s=cardinal s'. +Proof. +auto with set. +Qed. + +(* Properties of [subset] *) + +Lemma subset_refl: subset s s=true. +Proof. +auto with set. +Qed. + +Lemma subset_antisym: + subset s s'=true -> subset s' s=true -> equal s s'=true. +Proof. +auto with set. +Qed. + +Lemma subset_trans: + subset s s'=true -> subset s' s''=true -> subset s s''=true. +Proof. +do 3 rewrite <- subset_iff; intros. +apply subset_trans with s'; auto. +Qed. + +Lemma subset_equal: + equal s s'=true -> subset s s'=true. +Proof. +auto with set. +Qed. + +(** Properties of [choose] *) + +Lemma choose_mem_3: + is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. +Proof. +intros. +generalize (@choose_1 s) (@choose_2 s). +destruct (choose s);intros. +exists e;auto. +generalize (H1 (refl_equal None)); clear H1. +intros; rewrite (is_empty_1 H1) in H; discriminate. +Qed. + +Lemma choose_mem_4: choose empty=None. +Proof. +generalize (@choose_1 empty). +case (@choose empty);intros;auto. +elim (@empty_1 e); auto. +Qed. + +(** Properties of [add] *) + +Lemma add_mem_3: + mem y s=true -> mem y (add x s)=true. +Proof. +auto. +Qed. + +Lemma add_equal: + mem x s=true -> equal (add x s) s=true. +Proof. +auto with set. +Qed. + +(** Properties of [remove] *) + +Lemma remove_mem_3: + mem y (remove x s)=true -> mem y s=true. +Proof. +rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. +Qed. + +Lemma remove_equal: + mem x s=false -> equal (remove x s) s=true. +Proof. +intros; apply equal_1; apply remove_equal. +rewrite not_mem_iff; auto. +Qed. + +Lemma add_remove: + mem x s=true -> equal (add x (remove x s)) s=true. +Proof. +intros; apply equal_1; apply add_remove; auto. +Qed. + +Lemma remove_add: + mem x s=false -> equal (remove x (add x s)) s=true. +Proof. +intros; apply equal_1; apply remove_add; auto. +rewrite not_mem_iff; auto. +Qed. + +(** Properties of [is_empty] *) + +Lemma is_empty_cardinal: is_empty s = zerob (cardinal s). +Proof. +intros; apply bool_1; split; intros. +rewrite cardinal_1; simpl; auto. +assert (cardinal s = 0) by apply zerob_true_elim; auto. +auto. +Qed. + +(** Properties of [singleton] *) + +Lemma singleton_mem_1: mem x (singleton x)=true. +Proof. +auto with set. +Qed. + +Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. +Proof. +intros; rewrite singleton_b. +unfold ME.eqb; destruct (ME.eq_dec x y); intuition. +Qed. + +Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. +Proof. +auto. +Qed. + +(** Properties of [union] *) + +Lemma union_sym: + equal (union s s') (union s' s)=true. +Proof. +auto with set. +Qed. + +Lemma union_subset_equal: + subset s s'=true -> equal (union s s') s'=true. +Proof. +auto with set. +Qed. + +Lemma union_equal_1: + equal s s'=true-> equal (union s s'') (union s' s'')=true. +Proof. +auto with set. +Qed. + +Lemma union_equal_2: + equal s' s''=true-> equal (union s s') (union s s'')=true. +Proof. +auto with set. +Qed. + +Lemma union_assoc: + equal (union (union s s') s'') (union s (union s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma add_union_singleton: + equal (add x s) (union (singleton x) s)=true. +Proof. +auto with set. +Qed. + +Lemma union_add: + equal (union (add x s) s') (add x (union s s'))=true. +Proof. +auto with set. +Qed. + +(* caracterisation of [union] via [subset] *) + +Lemma union_subset_1: subset s (union s s')=true. +Proof. +auto with set. +Qed. + +Lemma union_subset_2: subset s' (union s s')=true. +Proof. +auto with set. +Qed. + +Lemma union_subset_3: + subset s s''=true -> subset s' s''=true -> + subset (union s s') s''=true. +Proof. +intros; apply subset_1; apply union_subset_3; auto. +Qed. + +(** Properties of [inter] *) + +Lemma inter_sym: equal (inter s s') (inter s' s)=true. +Proof. +auto with set. +Qed. + +Lemma inter_subset_equal: + subset s s'=true -> equal (inter s s') s=true. +Proof. +auto with set. +Qed. + +Lemma inter_equal_1: + equal s s'=true -> equal (inter s s'') (inter s' s'')=true. +Proof. +auto with set. +Qed. + +Lemma inter_equal_2: + equal s' s''=true -> equal (inter s s') (inter s s'')=true. +Proof. +auto with set. +Qed. + +Lemma inter_assoc: + equal (inter (inter s s') s'') (inter s (inter s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma union_inter_1: + equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma union_inter_2: + equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma inter_add_1: mem x s'=true -> + equal (inter (add x s) s') (add x (inter s s'))=true. +Proof. +auto with set. +Qed. + +Lemma inter_add_2: mem x s'=false -> + equal (inter (add x s) s') (inter s s')=true. +Proof. +intros; apply equal_1; apply inter_add_2. +rewrite not_mem_iff; auto. +Qed. + +(* caracterisation of [union] via [subset] *) + +Lemma inter_subset_1: subset (inter s s') s=true. +Proof. +auto with set. +Qed. + +Lemma inter_subset_2: subset (inter s s') s'=true. +Proof. +auto with set. +Qed. + +Lemma inter_subset_3: + subset s'' s=true -> subset s'' s'=true -> + subset s'' (inter s s')=true. +Proof. +intros; apply subset_1; apply inter_subset_3; auto. +Qed. + +(** Properties of [diff] *) + +Lemma diff_subset: subset (diff s s') s=true. +Proof. +auto with set. +Qed. + +Lemma diff_subset_equal: + subset s s'=true -> equal (diff s s') empty=true. +Proof. +auto with set. +Qed. + +Lemma remove_inter_singleton: + equal (remove x s) (diff s (singleton x))=true. +Proof. +auto with set. +Qed. + +Lemma diff_inter_empty: + equal (inter (diff s s') (inter s s')) empty=true. +Proof. +auto with set. +Qed. + +Lemma diff_inter_all: + equal (union (diff s s') (inter s s')) s=true. +Proof. +auto with set. +Qed. + +End BasicProperties. + +Hint Immediate empty_mem is_empty_equal_empty add_mem_1 + remove_mem_1 singleton_equal_add union_mem inter_mem + diff_mem equal_sym add_remove remove_add : set. +Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 + choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal + subset_refl subset_equal subset_antisym + add_mem_3 add_equal remove_mem_3 remove_equal : set. + + +(** General recursion principes based on [cardinal] *) + +Lemma cardinal_set_rec: forall (P:t->Type), + (forall s s', equal s s'=true -> P s -> P s') -> + (forall s x, mem x s=false -> P s -> P (add x s)) -> + P empty -> forall n s, cardinal s=n -> P s. +Proof. +intros. +apply cardinal_induction with n; auto; intros. +apply X with empty; auto with set. +apply X with (add x s0); auto with set. +apply equal_1; intro a; rewrite add_iff; rewrite (H1 a); tauto. +apply X0; auto with set; apply mem_3; auto. +Qed. + +Lemma set_rec: forall (P:t->Type), + (forall s s', equal s s'=true -> P s -> P s') -> + (forall s x, mem x s=false -> P s -> P (add x s)) -> + P empty -> forall s, P s. +Proof. +intros;apply cardinal_set_rec with (cardinal s);auto. +Qed. + +(** Properties of [fold] *) + +Lemma exclusive_set : forall s s' x, + ~In x s\/~In x s' <-> mem x s && mem x s'=false. +Proof. +intros; do 2 rewrite not_mem_iff. +destruct (mem x s); destruct (mem x s'); intuition. +Qed. + +Section Fold. +Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ 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: eqA (fold f empty i) i. +Proof. +apply fold_empty; auto. +Qed. + +Lemma fold_equal: + equal s s'=true -> eqA (fold f s i) (fold f s' i). +Proof. +intros; apply fold_equal with (eqA:=eqA); auto. +Qed. + +Lemma fold_add: + mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). +Proof. +intros; apply fold_add with (eqA:=eqA); auto. +rewrite not_mem_iff; auto. +Qed. + +Lemma add_fold: + mem x s=true -> eqA (fold f (add x s) i) (fold f s i). +Proof. +intros; apply add_fold with (eqA:=eqA); auto. +Qed. + +Lemma remove_fold_1: + mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). +Proof. +intros; apply remove_fold_1 with (eqA:=eqA); auto. +Qed. + +Lemma remove_fold_2: + mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). +Proof. +intros; apply remove_fold_2 with (eqA:=eqA); auto. +rewrite not_mem_iff; auto. +Qed. + +Lemma fold_union: + (forall x, mem x s && mem x s'=false) -> + eqA (fold f (union s s') i) (fold f s (fold f s' i)). +Proof. +intros; apply fold_union with (eqA:=eqA); auto. +intros; rewrite exclusive_set; auto. +Qed. + +End Fold. + +(** Properties of [cardinal] *) + +Lemma add_cardinal_1: + forall s x, mem x s=true -> cardinal (add x s)=cardinal s. +Proof. +auto with set. +Qed. + +Lemma add_cardinal_2: + forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). +Proof. +intros; apply add_cardinal_2; auto. +rewrite not_mem_iff; auto. +Qed. + +Lemma remove_cardinal_1: + forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. +Proof. +intros; apply remove_cardinal_1; auto. +Qed. + +Lemma remove_cardinal_2: + forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. +Proof. +auto with set. +Qed. + +Lemma union_cardinal: + forall s s', (forall x, mem x s && mem x s'=false) -> + cardinal (union s s')=cardinal s+cardinal s'. +Proof. +intros; apply union_cardinal; auto; intros. +rewrite exclusive_set; auto. +Qed. + +Lemma subset_cardinal: + forall s s', subset s s'=true -> cardinal s<=cardinal s'. +Proof. +intros; apply subset_cardinal; auto. +Qed. + +Section Bool. + +(** Properties of [filter] *) + +Variable f:elt->bool. +Variable Comp: compat_bool E.eq f. + +Let Comp' : compat_bool E.eq (fun x =>negb (f x)). +Proof. +unfold compat_bool in *; intros; f_equal; auto. +Qed. + +Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. +Proof. +intros; apply filter_b; auto. +Qed. + +Lemma for_all_filter: + forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). +Proof. +intros; apply bool_1; split; intros. +apply is_empty_1. +unfold Empty; intros. +rewrite filter_iff; auto. +red; destruct 1. +rewrite <- (@for_all_iff s f) in H; auto. +rewrite (H a H0) in H1; discriminate. +apply for_all_1; auto; red; intros. +revert H; rewrite <- is_empty_iff. +unfold Empty; intro H; generalize (H x); clear H. +rewrite filter_iff; auto. +destruct (f x); auto. +Qed. + +Lemma exists_filter : + forall s, exists_ f s=negb (is_empty (filter f s)). +Proof. +intros; apply bool_1; split; intros. +destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). +apply bool_6. +red; intros; apply (@is_empty_2 _ H0 a); auto. +generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)). +destruct (choose (filter f s)). +intros H0 _; apply exists_1; auto. +exists e; generalize (H0 e); rewrite filter_iff; auto. +intros _ H0. +rewrite (is_empty_1 (H0 (refl_equal None))) in H; auto; discriminate. +Qed. + +Lemma partition_filter_1: + forall s, equal (fst (partition f s)) (filter f s)=true. +Proof. +auto. +Qed. + +Lemma partition_filter_2: + forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. +Proof. +auto. +Qed. + +Lemma add_filter_1 : forall s s' x, + f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). +Proof. +unfold Add, MP.Add; intros. +repeat rewrite filter_iff; auto. +rewrite H0; clear H0. +assert (E.eq x y -> f y = true) by + intro H0; rewrite <- (Comp _ _ H0); auto. +tauto. +Qed. + +Lemma add_filter_2 : forall s s' x, + f x=false -> (Add x s s') -> filter f s [=] filter f s'. +Proof. +unfold Add, MP.Add, Equal; intros. +repeat rewrite filter_iff; auto. +rewrite H0; clear H0. +assert (f a = true -> ~E.eq x a). + intros H0 H1. + rewrite (Comp _ _ H1) in H. + rewrite H in H0; discriminate. +tauto. +Qed. + +Lemma union_filter: forall f g, (compat_bool E.eq f) -> (compat_bool E.eq g) -> + forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s. +Proof. +clear Comp' Comp f. +intros. +assert (compat_bool E.eq (fun x => orb (f x) (g x))). + unfold compat_bool; intros. + rewrite (H x y H1); rewrite (H0 x y H1); auto. +unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. +assert (f a || g a = true <-> f a = true \/ g a = true). + split; auto with bool. + intro H3; destruct (orb_prop _ _ H3); auto. +tauto. +Qed. + +(** Properties of [for_all] *) + +Lemma for_all_mem_1: forall s, + (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. +Proof. +intros. +rewrite for_all_filter; auto. +rewrite is_empty_equal_empty. +apply equal_mem_1;intros. +rewrite filter_b; auto. +rewrite empty_mem. +generalize (H a); case (mem a s);intros;auto. +rewrite H0;auto. +Qed. + +Lemma for_all_mem_2: forall s, + (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. +Proof. +intros. +rewrite for_all_filter in H; auto. +rewrite is_empty_equal_empty in H. +generalize (equal_mem_2 _ _ H x). +rewrite filter_b; auto. +rewrite empty_mem. +rewrite H0; simpl;intros. +replace true with (negb false);auto;apply negb_sym;auto. +Qed. + +Lemma for_all_mem_3: + forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. +Proof. +intros. +apply (bool_eq_ind (for_all f s));intros;auto. +rewrite for_all_filter in H1; auto. +rewrite is_empty_equal_empty in H1. +generalize (equal_mem_2 _ _ H1 x). +rewrite filter_b; auto. +rewrite empty_mem. +rewrite H. +rewrite H0. +simpl;auto. +Qed. + +Lemma for_all_mem_4: + forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. +Proof. +intros. +rewrite for_all_filter in H; auto. +destruct (choose_mem_3 _ H) as (x,(H0,H1));intros. +exists x. +rewrite filter_b in H1; auto. +elim (andb_prop _ _ H1). +split;auto. +replace false with (negb true);auto;apply negb_sym;auto. +Qed. + +(** Properties of [exists] *) + +Lemma for_all_exists: + forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). +Proof. +intros. +rewrite for_all_b; auto. +rewrite exists_b; auto. +induction (elements s); simpl; auto. +destruct (f a); simpl; auto. +Qed. + +End Bool. +Section Bool'. + +Variable f:elt->bool. +Variable Comp: compat_bool E.eq f. + +Let Comp' : compat_bool E.eq (fun x =>negb (f x)). +Proof. +unfold compat_bool in *; intros; f_equal; auto. +Qed. + +Lemma exists_mem_1: + forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. +Proof. +intros. +rewrite for_all_exists; auto. +rewrite for_all_mem_1;auto with bool. +intros;generalize (H x H0);intros. +symmetry;apply negb_sym;simpl;auto. +Qed. + +Lemma exists_mem_2: + forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. +Proof. +intros. +rewrite for_all_exists in H; auto. +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. +Qed. + +Lemma exists_mem_3: + forall s x, mem x s=true -> f x=true -> exists_ f s=true. +Proof. +intros. +rewrite for_all_exists; auto. +symmetry;apply negb_sym;simpl. +apply for_all_mem_3 with x;auto. +rewrite H0;auto. +Qed. + +Lemma exists_mem_4: + forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. +Proof. +intros. +rewrite for_all_exists in H; auto. +elim (for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros. +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. +Qed. + +End Bool'. + +Section Sum. + +(** Adding a valuation function on all elements of a set. *) + +Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. + +Lemma sum_plus : + forall f g, compat_nat E.eq f -> compat_nat E.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_op E.eq (@eq _) (fun x:elt =>plus (f x))). auto. +assert (ft : transpose (@eq _) (fun x:elt =>plus (f x))). red; intros; omega. +assert (gc : compat_op E.eq (@eq _) (fun x:elt => plus (g x))). auto. +assert (gt : transpose (@eq _) (fun x:elt =>plus (g x))). red; intros; omega. +assert (fgc : compat_op E.eq (@eq _) (fun x:elt =>plus ((f x)+(g x)))). auto. +assert (fgt : transpose (@eq _) (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega. +assert (st := gen_st nat). +intros s;pattern s; apply set_rec. +intros. +rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H). +rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H). +rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto. +intros; do 3 (rewrite (fold_add _ _ st);auto). +rewrite H0;simpl;omega. +intros; do 3 rewrite (fold_empty _ _ st);auto. +Qed. + +Lemma sum_filter : forall f, (compat_bool E.eq f) -> + forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). +Proof. +unfold sum; intros f Hf. +assert (st := gen_st nat). +assert (cc : compat_op E.eq (@eq _) (fun x => plus (if f x then 1 else 0))). + unfold compat_op; intros. + rewrite (Hf x x' H); auto. +assert (ct : transpose (@eq _) (fun x => plus (if f x then 1 else 0))). + unfold transpose; intros; omega. +intros s;pattern s; apply set_rec. +intros. +change elt with E.t. +rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H). +rewrite <- (MP.Equal_cardinal (filter_equal Hf (equal_2 H))); auto. +intros; rewrite (fold_add _ _ st _ cc ct); auto. +generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) . +assert (~ In x (filter f s0)). + intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H. +case (f x); simpl; intros. +rewrite (MP.cardinal_2 H1 (H2 (refl_equal true) (MP.Add_add s0 x))); auto. +rewrite <- (MP.Equal_cardinal (H3 (refl_equal false) (MP.Add_add s0 x))); auto. +intros; rewrite (fold_empty _ _ st);auto. +rewrite MP.cardinal_1; auto. +unfold Empty; intros. +rewrite filter_iff; auto; set_iff; tauto. +Qed. + +Lemma fold_compat : + forall (A:Set)(eqA:A->A->Prop)(st:(Setoid_Theory _ eqA)) + (f g:elt->A->A), + (compat_op E.eq eqA f) -> (transpose eqA f) -> + (compat_op E.eq eqA g) -> (transpose eqA g) -> + forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> + (eqA (fold f s i) (fold g s i)). +Proof. +intros A eqA st f g fc ft gc gt i. +intro s; pattern s; apply set_rec; intros. +trans_st (fold f s0 i). +apply fold_equal with (eqA:=eqA); auto. +rewrite equal_sym; auto. +trans_st (fold g s0 i). +apply H0; intros; apply H1; auto. +elim (equal_2 H x); auto; intros. +apply fold_equal with (eqA:=eqA); auto. +trans_st (f x (fold f s0 i)). +apply fold_add with (eqA:=eqA); auto. +trans_st (g x (fold f s0 i)). +trans_st (g x (fold g s0 i)). +sym_st; apply fold_add with (eqA:=eqA); auto. +trans_st i; [idtac | sym_st ]; apply fold_empty; auto. +Qed. + +Lemma sum_compat : + forall f g, compat_nat E.eq f -> compat_nat E.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 _ (@eq nat)); auto. +unfold transpose; intros; omega. +unfold transpose; intros; omega. +Qed. + +End Sum. + +End EqProperties. diff --git a/theories/FSets/FSetFacts.v b/theories/FSets/FSetFacts.v new file mode 100644 index 00000000..d8c0b802 --- /dev/null +++ b/theories/FSets/FSetFacts.v @@ -0,0 +1,409 @@ +(***********************************************************************) +(* 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: FSetFacts.v 8681 2006-04-05 11:56:14Z letouzey $ *) + +(** * Finite sets library *) + +(** This functor derives additional facts from [FSetInterface.S]. These + facts are mainly the specifications of [FSetInterface.S] written using + different styles: equivalence and boolean equalities. + Moreover, we prove that [E.Eq] and [Equal] are setoid equalities. +*) + +Require Export FSetInterface. +Set Implicit Arguments. +Unset Strict Implicit. + +Module Facts (M: S). +Module ME := OrderedTypeFacts M.E. +Import ME. +Import M. +Import Logic. (* to unmask [eq] *) +Import Peano. (* to unmask [lt] *) + +(** * Specifications written using equivalences *) + +Section IffSpec. +Variable s s' s'' : t. +Variable x y z : elt. + +Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s). +Proof. +split; apply In_1; auto. +Qed. + +Lemma mem_iff : In x s <-> mem x s = true. +Proof. +split; [apply mem_1|apply mem_2]. +Qed. + +Lemma not_mem_iff : ~In x s <-> mem x s = false. +Proof. +rewrite mem_iff; destruct (mem x s); intuition. +Qed. + +Lemma equal_iff : s[=]s' <-> equal s s' = true. +Proof. +split; [apply equal_1|apply equal_2]. +Qed. + +Lemma subset_iff : s[<=]s' <-> subset s s' = true. +Proof. +split; [apply subset_1|apply subset_2]. +Qed. + +Lemma empty_iff : In x empty <-> False. +Proof. +intuition; apply (empty_1 H). +Qed. + +Lemma is_empty_iff : Empty s <-> is_empty s = true. +Proof. +split; [apply is_empty_1|apply is_empty_2]. +Qed. + +Lemma singleton_iff : In y (singleton x) <-> E.eq x y. +Proof. +split; [apply singleton_1|apply singleton_2]. +Qed. + +Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. +Proof. +split; [ | destruct 1; [apply add_1|apply add_2]]; auto. +destruct (eq_dec x y) as [E|E]; auto. +intro H; right; exact (add_3 E H). +Qed. + +Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s) <-> In y s). +Proof. +split; [apply add_3|apply add_2]; auto. +Qed. + +Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y. +Proof. +split; [split; [apply remove_3 with x |] | destruct 1; apply remove_2]; auto. +intro. +apply (remove_1 H0 H). +Qed. + +Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s). +Proof. +split; [apply remove_3|apply remove_2]; auto. +Qed. + +Lemma union_iff : In x (union s s') <-> In x s \/ In x s'. +Proof. +split; [apply union_1 | destruct 1; [apply union_2|apply union_3]]; auto. +Qed. + +Lemma inter_iff : In x (inter s s') <-> In x s /\ In x s'. +Proof. +split; [split; [apply inter_1 with s' | apply inter_2 with s] | destruct 1; apply inter_3]; auto. +Qed. + +Lemma diff_iff : In x (diff s s') <-> In x s /\ ~ In x s'. +Proof. +split; [split; [apply diff_1 with s' | apply diff_2 with s] | destruct 1; apply diff_3]; auto. +Qed. + +Variable f : elt->bool. + +Lemma filter_iff : compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true). +Proof. +split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. +Qed. + +Lemma for_all_iff : compat_bool E.eq f -> + (For_all (fun x => f x = true) s <-> for_all f s = true). +Proof. +split; [apply for_all_1 | apply for_all_2]; auto. +Qed. + +Lemma exists_iff : compat_bool E.eq f -> + (Exists (fun x => f x = true) s <-> exists_ f s = true). +Proof. +split; [apply exists_1 | apply exists_2]; auto. +Qed. + +Lemma elements_iff : In x s <-> ME.In x (elements s). +Proof. +split; [apply elements_1 | apply elements_2]. +Qed. + +End IffSpec. + +(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) + +Ltac set_iff := + repeat (progress ( + rewrite add_iff || rewrite remove_iff || rewrite singleton_iff + || rewrite union_iff || rewrite inter_iff || rewrite diff_iff + || rewrite empty_iff)). + +(** * Specifications written using boolean predicates *) + +Section BoolSpec. +Variable s s' s'' : t. +Variable x y z : elt. + +Lemma mem_b : E.eq x y -> mem x s = mem y s. +Proof. +intros. +generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). +destruct (mem x s); destruct (mem y s); intuition. +Qed. + +Lemma add_b : mem y (add x s) = eqb x y || mem y s. +Proof. +generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb. +destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition. +Qed. + +Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s. +Proof. +intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H). +destruct (mem y s); destruct (mem y (add x s)); intuition. +Qed. + +Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y). +Proof. +generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb. +destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition. +Qed. + +Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s. +Proof. +intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H). +destruct (mem y s); destruct (mem y (remove x s)); intuition. +Qed. + +Lemma singleton_b : mem y (singleton x) = eqb x y. +Proof. +generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. +destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. +Qed. + +Lemma union_b : mem x (union s s') = mem x s || mem x s'. +Proof. +generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x). +destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition. +Qed. + +Lemma inter_b : mem x (inter s s') = mem x s && mem x s'. +Proof. +generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x). +destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition. +Qed. + +Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s'). +Proof. +generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x). +destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition. +Qed. + +Lemma elements_b : mem x s = existsb (eqb x) (elements s). +Proof. +generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)). +rewrite InA_alt. +destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros. +symmetry. +rewrite H1. +destruct H0 as (H0,_). +destruct H0 as (a,(Ha1,Ha2)); [ intuition |]. +exists a; intuition. +unfold eqb; destruct (eq_dec x a); auto. +rewrite <- H. +rewrite H0. +destruct H1 as (H1,_). +destruct H1 as (a,(Ha1,Ha2)); [intuition|]. +exists a; intuition. +unfold eqb in *; destruct (eq_dec x a); auto; discriminate. +Qed. + +Variable f : elt->bool. + +Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x. +Proof. +intros. +generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). +destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. +Qed. + +Lemma for_all_b : compat_bool E.eq f -> + for_all f s = forallb f (elements s). +Proof. +intros. +generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s). +unfold For_all. +destruct (forallb f (elements s)); destruct (for_all f s); auto; intros. +rewrite <- H1; intros. +destruct H0 as (H0,_). +rewrite (H2 x0) in H3. +rewrite (InA_alt E.eq x0 (elements s)) in H3. +destruct H3 as (a,(Ha1,Ha2)). +rewrite (H _ _ Ha1). +apply H0; auto. +symmetry. +rewrite H0; intros. +destruct H1 as (_,H1). +apply H1; auto. +Qed. + +Lemma exists_b : compat_bool E.eq f -> + exists_ f s = existsb f (elements s). +Proof. +intros. +generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s). +unfold Exists. +destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. +rewrite <- H1; intros. +destruct H0 as (H0,_). +destruct H0 as (a,(Ha1,Ha2)); auto. +exists a; auto. +symmetry. +rewrite H0. +destruct H1 as (_,H1). +destruct H1 as (a,(Ha1,Ha2)); auto. +rewrite (H2 a) in Ha1. +rewrite (InA_alt E.eq a (elements s)) in Ha1. +destruct Ha1 as (b,(Hb1,Hb2)). +exists b; auto. +rewrite <- (H _ _ Hb1); auto. +Qed. + +End BoolSpec. + +(** * [E.eq] and [Equal] are setoid equalities *) + +Definition E_ST : Setoid_Theory elt E.eq. +Proof. +constructor; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. +Qed. + +Add Setoid elt E.eq E_ST as EltSetoid. + +Definition Equal_ST : Setoid_Theory t Equal. +Proof. +constructor; [apply eq_refl | apply eq_sym | apply eq_trans]. +Qed. + +Add Setoid t Equal Equal_ST as EqualSetoid. + +Add Morphism In with signature E.eq ==> Equal ==> iff as In_m. +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. +Proof. +unfold Equal; intros s s' H. +generalize (is_empty_iff s)(is_empty_iff s'). +destruct (is_empty s); destruct (is_empty s'); + unfold Empty; auto; intros. +symmetry. +rewrite <- H1; intros a Ha. +rewrite <- (H a) in Ha. +destruct H0 as (_,H0). +exact (H0 (refl_equal true) _ Ha). +rewrite <- H0; intros a Ha. +rewrite (H a) in Ha. +destruct H1 as (_,H1). +exact (H1 (refl_equal true) _ Ha). +Qed. + +Add Morphism Empty with signature Equal ==> iff as Empty_m. +Proof. +intros; do 2 rewrite is_empty_iff; rewrite H; intuition. +Qed. + +Add Morphism mem : mem_m. +Proof. +unfold Equal; intros x y H s s' H0. +generalize (H0 x); clear H0; rewrite (In_eq_iff s' H). +generalize (mem_iff s x)(mem_iff s' y). +destruct (mem x s); destruct (mem y s'); intuition. +Qed. + +Add Morphism singleton : singleton_m. +Proof. +unfold Equal; intros x y H a. +do 2 rewrite singleton_iff; split; order. +Qed. + +Add Morphism add : add_m. +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. +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. +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. +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. +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. +unfold Equal, Subset; firstorder. +Qed. + +Add Morphism subset : subset_m. +Proof. +intros s s' H s'' s''' H0. +generalize (subset_iff s s'') (subset_iff s' s'''). +destruct (subset s s''); destruct (subset s' s'''); auto; intros. +rewrite H in H1; rewrite H0 in H1; intuition. +rewrite H in H1; rewrite H0 in H1; intuition. +Qed. + +Add Morphism equal : equal_m. +Proof. +intros s s' H s'' s''' H0. +generalize (equal_iff s s'') (equal_iff s' s'''). +destruct (equal s s''); destruct (equal s' s'''); auto; intros. +rewrite H in H1; rewrite H0 in H1; intuition. +rewrite H in H1; rewrite H0 in H1; intuition. +Qed. + +(* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism + without additional hypothesis on [f]. For instance: *) + +Lemma filter_equal : forall f, compat_bool E.eq f -> + forall s s', s[=]s' -> filter f s [=] filter f s'. +Proof. +unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. +Qed. + +(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid + structures on [list elt] and [option elt]. *) + +(* Later: +Add Morphism cardinal ; cardinal_m. +*) + +End Facts. diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v new file mode 100644 index 00000000..c177abfe --- /dev/null +++ b/theories/FSets/FSetInterface.v @@ -0,0 +1,420 @@ +(***********************************************************************) +(* 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: FSetInterface.v 8671 2006-03-29 08:31:28Z letouzey $ *) + +(** * Finite set library *) + +(** Set interfaces *) + +(* begin hide *) +Require Export Bool. +Require Export OrderedType. +Set Implicit Arguments. +Unset Strict Implicit. +(* end hide *) + +(** Compatibility of a boolean function with respect to an equality. *) +Definition compat_bool (A:Set)(eqA: A->A->Prop)(f: A-> bool) := + forall x y : A, eqA x y -> f x = f y. + +(** Compatibility of a predicate with respect to an equality. *) +Definition compat_P (A:Set)(eqA: A->A->Prop)(P : A -> Prop) := + forall x y : A, eqA x y -> P x -> P y. + +Hint Unfold compat_bool compat_P. + +(** * Non-dependent signature + + Signature [S] presents sets as purely informative programs + together with axioms *) + +Module Type S. + + Declare Module E : OrderedType. + Definition elt := E.t. + + Parameter t : Set. (** the abstract type of sets *) + + (** Logical predicates *) + Parameter In : elt -> t -> Prop. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + + Parameter empty : t. + (** The empty set. *) + + Parameter is_empty : t -> bool. + (** Test whether a set is empty or not. *) + + Parameter mem : elt -> t -> bool. + (** [mem x s] tests whether [x] belongs to the set [s]. *) + + Parameter add : elt -> t -> t. + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + + Parameter singleton : elt -> t. + (** [singleton x] returns the one-element set containing only [x]. *) + + Parameter remove : elt -> t -> t. + (** [remove x s] returns a set containing all elements of [s], + except [x]. If [x] was not in [s], [s] is returned unchanged. *) + + Parameter union : t -> t -> t. + (** Set union. *) + + Parameter inter : t -> t -> t. + (** Set intersection. *) + + Parameter diff : t -> t -> t. + (** Set difference. *) + + Definition eq : t -> t -> Prop := Equal. + Parameter lt : t -> t -> Prop. + Parameter compare : forall s s' : t, Compare lt eq s s'. + (** Total ordering between sets. Can be used as the ordering function + for doing sets of sets. *) + + Parameter equal : t -> t -> bool. + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + + Parameter subset : t -> t -> bool. + (** [subset s1 s2] tests whether the set [s1] is a subset of + the set [s2]. *) + + (** Coq comment: [iter] is useless in a purely functional world *) + (** iter: (elt -> unit) -> set -> unit. i*) + (** [iter f s] applies [f] in turn to all elements of [s]. + The order in which the elements of [s] are presented to [f] + is unspecified. *) + + Parameter fold : forall A : Set, (elt -> A -> A) -> t -> A -> A. + (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], + where [x1 ... xN] are the elements of [s], in increasing order. *) + + Parameter for_all : (elt -> bool) -> t -> bool. + (** [for_all p s] checks if all elements of the set + satisfy the predicate [p]. *) + + Parameter exists_ : (elt -> bool) -> t -> bool. + (** [exists p s] checks if at least one element of + the set satisfies the predicate [p]. *) + + Parameter filter : (elt -> bool) -> t -> t. + (** [filter p s] returns the set of all elements in [s] + that satisfy predicate [p]. *) + + Parameter partition : (elt -> bool) -> t -> t * t. + (** [partition p s] returns a pair of sets [(s1, s2)], where + [s1] is the set of all the elements of [s] that satisfy the + predicate [p], and [s2] is the set of all the elements of + [s] that do not satisfy [p]. *) + + Parameter cardinal : t -> nat. + (** Return the number of elements of a set. *) + (** Coq comment: nat instead of int ... *) + + Parameter elements : t -> list elt. + (** Return the list of all elements of the given set. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Set.Make}. *) + + Parameter min_elt : t -> option elt. + (** Return the smallest element of the given set + (with respect to the [Ord.compare] ordering), or raise + [Not_found] if the set is empty. *) + (** Coq comment: [Not_found] is represented by the option type *) + + Parameter max_elt : t -> option elt. + (** Same as {!Set.S.min_elt}, but returns the largest element of the + given set. *) + (** Coq comment: [Not_found] is represented by the option type *) + + Parameter choose : t -> option elt. + (** Return one element of the given set, or raise [Not_found] if + the set is empty. Which element is chosen is unspecified, + but equal elements will be chosen for equal sets. *) + (** Coq comment: [Not_found] is represented by the option type *) + + Section Spec. + + Variable s s' s'' : t. + Variable x y z : elt. + + (** Specification of [In] *) + Parameter In_1 : E.eq x y -> In x s -> In y s. + + (** Specification of [eq] *) + Parameter eq_refl : eq s s. + Parameter eq_sym : eq s s' -> eq s' s. + Parameter eq_trans : eq s s' -> eq s' s'' -> eq s s''. + + (** Specification of [lt] *) + Parameter lt_trans : lt s s' -> lt s' s'' -> lt s s''. + Parameter lt_not_eq : lt s s' -> ~ eq s s'. + + (** Specification of [mem] *) + Parameter mem_1 : In x s -> mem x s = true. + Parameter mem_2 : mem x s = true -> In x s. + + (** Specification of [equal] *) + Parameter equal_1 : s[=]s' -> equal s s' = true. + Parameter equal_2 : equal s s' = true ->s[=]s'. + + (** Specification of [subset] *) + Parameter subset_1 : s[<=]s' -> subset s s' = true. + Parameter subset_2 : subset s s' = true -> s[<=]s'. + + (** Specification of [empty] *) + Parameter empty_1 : Empty empty. + + (** Specification of [is_empty] *) + Parameter is_empty_1 : Empty s -> is_empty s = true. + Parameter is_empty_2 : is_empty s = true -> Empty s. + + (** Specification of [add] *) + Parameter add_1 : E.eq x y -> In y (add x s). + Parameter add_2 : In y s -> In y (add x s). + Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. + + (** Specification of [remove] *) + Parameter remove_1 : E.eq x y -> ~ In y (remove x s). + Parameter remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). + Parameter remove_3 : In y (remove x s) -> In y s. + + (** Specification of [singleton] *) + Parameter singleton_1 : In y (singleton x) -> E.eq x y. + Parameter singleton_2 : E.eq x y -> In y (singleton x). + + (** Specification of [union] *) + Parameter union_1 : In x (union s s') -> In x s \/ In x s'. + Parameter union_2 : In x s -> In x (union s s'). + Parameter union_3 : In x s' -> In x (union s s'). + + (** Specification of [inter] *) + Parameter inter_1 : In x (inter s s') -> In x s. + Parameter inter_2 : In x (inter s s') -> In x s'. + Parameter inter_3 : In x s -> In x s' -> In x (inter s s'). + + (** Specification of [diff] *) + Parameter diff_1 : In x (diff s s') -> In x s. + Parameter diff_2 : In x (diff s s') -> ~ In x s'. + Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s'). + + (** Specification of [fold] *) + Parameter fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + + (** Specification of [cardinal] *) + Parameter cardinal_1 : cardinal s = length (elements s). + + Section Filter. + + Variable f : elt -> bool. + + (** Specification of [filter] *) + Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. + Parameter filter_3 : + compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). + + (** Specification of [for_all] *) + Parameter for_all_1 : + compat_bool E.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true. + Parameter for_all_2 : + compat_bool E.eq f -> + for_all f s = true -> For_all (fun x => f x = true) s. + + (** Specification of [exists] *) + Parameter exists_1 : + compat_bool E.eq f -> + Exists (fun x => f x = true) s -> exists_ f s = true. + Parameter exists_2 : + compat_bool E.eq f -> + exists_ f s = true -> Exists (fun x => f x = true) s. + + (** Specification of [partition] *) + Parameter partition_1 : compat_bool E.eq f -> + fst (partition f s) [=] filter f s. + Parameter partition_2 : compat_bool E.eq f -> + snd (partition f s) [=] filter (fun x => negb (f x)) s. + + (** 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. + Parameter elements_3 : sort E.lt (elements s). + + (** Specification of [min_elt] *) + Parameter min_elt_1 : min_elt s = Some x -> In x s. + Parameter min_elt_2 : min_elt s = Some x -> In y s -> ~ E.lt y x. + Parameter min_elt_3 : min_elt s = None -> Empty s. + + (** Specification of [max_elt] *) + Parameter max_elt_1 : max_elt s = Some x -> In x s. + Parameter max_elt_2 : max_elt s = Some x -> In y s -> ~ E.lt x y. + Parameter max_elt_3 : max_elt s = None -> Empty s. + + (** Specification of [choose] *) + Parameter choose_1 : choose s = Some x -> In x s. + Parameter choose_2 : choose s = None -> Empty s. +(* Parameter choose_equal: + (equal s s')=true -> E.eq (choose s) (choose s'). *) + + End Filter. + End Spec. + + (* begin hide *) + Hint Immediate In_1. + + Hint Resolve mem_1 mem_2 equal_1 equal_2 subset_1 subset_2 empty_1 + is_empty_1 is_empty_2 choose_1 choose_2 add_1 add_2 add_3 remove_1 + remove_2 remove_3 singleton_1 singleton_2 union_1 union_2 union_3 inter_1 + inter_2 inter_3 diff_1 diff_2 diff_3 filter_1 filter_2 filter_3 for_all_1 + for_all_2 exists_1 exists_2 partition_1 partition_2 elements_1 elements_2 + elements_3 min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3. + (* end hide *) + +End S. + +(** * Dependent signature + + Signature [Sdep] presents sets using dependent types *) + +Module Type Sdep. + + Declare Module E : OrderedType. + Definition elt := E.t. + + Parameter t : Set. + + Parameter In : elt -> t -> Prop. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + + Definition eq : t -> t -> Prop := Equal. + Parameter lt : t -> t -> Prop. + Parameter compare : forall s s' : t, Compare lt eq s s'. + + Parameter eq_refl : forall s : t, eq s s. + Parameter eq_sym : forall s s' : t, eq s s' -> eq s' s. + Parameter eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. + Parameter lt_trans : forall s s' s'' : t, lt s s' -> lt s' s'' -> lt s s''. + Parameter lt_not_eq : forall s s' : t, lt s s' -> ~ eq s s'. + + Parameter eq_In : forall (s : t) (x y : elt), E.eq x y -> In x s -> In y s. + + Parameter empty : {s : t | Empty s}. + + Parameter is_empty : forall s : t, {Empty s} + {~ Empty s}. + + Parameter mem : forall (x : elt) (s : t), {In x s} + {~ In x s}. + + Parameter add : forall (x : elt) (s : t), {s' : t | Add x s s'}. + + Parameter + singleton : forall x : elt, {s : t | forall y : elt, In y s <-> E.eq x y}. + + Parameter + remove : + forall (x : elt) (s : t), + {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. + + Parameter + union : + forall s s' : t, + {s'' : t | forall x : elt, In x s'' <-> In x s \/ In x s'}. + + Parameter + inter : + forall s s' : t, + {s'' : t | forall x : elt, In x s'' <-> In x s /\ In x s'}. + + Parameter + diff : + forall s s' : t, + {s'' : t | forall x : elt, In x s'' <-> In x s /\ ~ In x s'}. + + Parameter equal : forall s s' : t, {s[=]s'} + {~ s[=]s'}. + + Parameter subset : forall s s' : t, {Subset s s'} + {~ Subset s s'}. + + Parameter + filter : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) + (s : t), + {s' : t | compat_P E.eq P -> forall x : elt, In x s' <-> In x s /\ P x}. + + Parameter + for_all : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) + (s : t), + {compat_P E.eq P -> For_all P s} + {compat_P E.eq P -> ~ For_all P s}. + + Parameter + exists_ : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) + (s : t), + {compat_P E.eq P -> Exists P s} + {compat_P E.eq P -> ~ Exists P s}. + + Parameter + partition : + forall (P : elt -> Prop) (Pdec : forall x : elt, {P x} + {~ P x}) + (s : t), + {partition : t * t | + let (s1, s2) := partition in + compat_P E.eq P -> + For_all P s1 /\ + For_all (fun x => ~ P x) s2 /\ + (forall x : elt, In x s <-> In x s1 \/ In x s2)}. + + Parameter + elements : + forall s : t, + {l : list elt | + sort E.lt l /\ (forall x : elt, In x s <-> InA E.eq x l)}. + + Parameter + fold : + forall (A : Set) (f : elt -> A -> A) (s : t) (i : A), + {r : A | let (l,_) := elements s in + r = fold_left (fun a e => f e a) l i}. + + Parameter + cardinal : + forall s : t, + {r : nat | let (l,_) := elements s in r = length l }. + + Parameter + min_elt : + forall s : t, + {x : elt | In x s /\ For_all (fun y => ~ E.lt y x) s} + {Empty s}. + + Parameter + max_elt : + forall s : t, + {x : elt | In x s /\ For_all (fun y => ~ E.lt x y) s} + {Empty s}. + + Parameter choose : forall s : t, {x : elt | In x s} + {Empty s}. + +End Sdep. diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v new file mode 100644 index 00000000..ca86ffcc --- /dev/null +++ b/theories/FSets/FSetList.v @@ -0,0 +1,1163 @@ +(***********************************************************************) +(* 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: FSetList.v 8667 2006-03-28 11:59:44Z letouzey $ *) + +(** * Finite sets library *) + +(** 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 + + 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 E := X. + 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 : Set) (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. *) + + 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 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 fold_1 : + forall (s : t) (Hs : Sort s) (A : Set) (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 Raw. + +(** * Encapsulation + + Now, in order to really provide a functor implementing [S], we + need to encapsulate everything into a type of strictly ordered lists. *) + +Module Make (X: OrderedType) <: S with Module E := X. + + Module E := X. + Module Raw := Raw X. + + Record slist : Set := {this :> Raw.t; sorted : sort X.lt this}. + Definition t := slist. + Definition elt := X.t. + + Definition In (x : elt) (s : t) := InA X.eq x s.(this). + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Definition In_1 (s : t) := Raw.MX.In_eq (l:=s.(this)). + + Definition mem (x : elt) (s : t) := Raw.mem x s. + Definition mem_1 (s : t) := Raw.mem_1 (sorted s). + Definition mem_2 (s : t) := Raw.mem_2 (s:=s). + + Definition add x s := Build_slist (Raw.add_sort (sorted s) x). + Definition add_1 (s : t) := Raw.add_1 (sorted s). + Definition add_2 (s : t) := Raw.add_2 (sorted s). + Definition add_3 (s : t) := Raw.add_3 (sorted s). + + Definition remove x s := Build_slist (Raw.remove_sort (sorted s) x). + Definition remove_1 (s : t) := Raw.remove_1 (sorted s). + Definition remove_2 (s : t) := Raw.remove_2 (sorted s). + Definition remove_3 (s : t) := Raw.remove_3 (sorted s). + + Definition singleton x := Build_slist (Raw.singleton_sort x). + Definition singleton_1 := Raw.singleton_1. + Definition singleton_2 := Raw.singleton_2. + + Definition union (s s' : t) := + Build_slist (Raw.union_sort (sorted s) (sorted s')). + Definition union_1 (s s' : t) := Raw.union_1 (sorted s) (sorted s'). + Definition union_2 (s s' : t) := Raw.union_2 (sorted s) (sorted s'). + Definition union_3 (s s' : t) := Raw.union_3 (sorted s) (sorted s'). + + Definition inter (s s' : t) := + Build_slist (Raw.inter_sort (sorted s) (sorted s')). + Definition inter_1 (s s' : t) := Raw.inter_1 (sorted s) (sorted s'). + Definition inter_2 (s s' : t) := Raw.inter_2 (sorted s) (sorted s'). + Definition inter_3 (s s' : t) := Raw.inter_3 (sorted s) (sorted s'). + + Definition diff (s s' : t) := + Build_slist (Raw.diff_sort (sorted s) (sorted s')). + Definition diff_1 (s s' : t) := Raw.diff_1 (sorted s) (sorted s'). + Definition diff_2 (s s' : t) := Raw.diff_2 (sorted s) (sorted s'). + Definition diff_3 (s s' : t) := Raw.diff_3 (sorted s) (sorted s'). + + Definition equal (s s' : t) := Raw.equal s s'. + Definition equal_1 (s s' : t) := Raw.equal_1 (sorted s) (sorted s'). + Definition equal_2 (s s' : t) := Raw.equal_2 (s:=s) (s':=s'). + + Definition subset (s s' : t) := Raw.subset s s'. + Definition subset_1 (s s' : t) := Raw.subset_1 (sorted s) (sorted s'). + Definition subset_2 (s s' : t) := Raw.subset_2 (s:=s) (s':=s'). + + Definition empty := Build_slist Raw.empty_sort. + Definition empty_1 := Raw.empty_1. + + Definition is_empty (s : t) := Raw.is_empty s. + Definition is_empty_1 (s : t) := Raw.is_empty_1 (s:=s). + Definition is_empty_2 (s : t) := Raw.is_empty_2 (s:=s). + + Definition elements (s : t) := Raw.elements s. + Definition elements_1 (s : t) := Raw.elements_1 (s:=s). + Definition elements_2 (s : t) := Raw.elements_2 (s:=s). + Definition elements_3 (s : t) := Raw.elements_3 (sorted s). + + Definition min_elt (s : t) := Raw.min_elt s. + Definition min_elt_1 (s : t) := Raw.min_elt_1 (s:=s). + Definition min_elt_2 (s : t) := Raw.min_elt_2 (sorted s). + Definition min_elt_3 (s : t) := Raw.min_elt_3 (s:=s). + + Definition max_elt (s : t) := Raw.max_elt s. + Definition max_elt_1 (s : t) := Raw.max_elt_1 (s:=s). + Definition max_elt_2 (s : t) := Raw.max_elt_2 (sorted s). + Definition max_elt_3 (s : t) := Raw.max_elt_3 (s:=s). + + Definition choose := min_elt. + Definition choose_1 := min_elt_1. + Definition choose_2 := min_elt_3. + + Definition fold (B : Set) (f : elt -> B -> B) (s : t) := Raw.fold (B:=B) f s. + Definition fold_1 (s : t) := Raw.fold_1 (sorted s). + + Definition cardinal (s : t) := Raw.cardinal s. + Definition cardinal_1 (s : t) := Raw.cardinal_1 (sorted s). + + Definition filter (f : elt -> bool) (s : t) := + Build_slist (Raw.filter_sort (sorted s) f). + Definition filter_1 (s : t) := Raw.filter_1 (s:=s). + Definition filter_2 (s : t) := Raw.filter_2 (s:=s). + Definition filter_3 (s : t) := Raw.filter_3 (s:=s). + + Definition for_all (f : elt -> bool) (s : t) := Raw.for_all f s. + Definition for_all_1 (s : t) := Raw.for_all_1 (s:=s). + Definition for_all_2 (s : t) := Raw.for_all_2 (s:=s). + + Definition exists_ (f : elt -> bool) (s : t) := Raw.exists_ f s. + Definition exists_1 (s : t) := Raw.exists_1 (s:=s). + Definition exists_2 (s : t) := Raw.exists_2 (s:=s). + + Definition partition (f : elt -> bool) (s : 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 partition_1 (s : t) := Raw.partition_1 s. + Definition partition_2 (s : t) := Raw.partition_2 s. + + Definition eq (s s' : t) := Raw.eq s s'. + Definition eq_refl (s : t) := Raw.eq_refl s. + Definition eq_sym (s s' : t) := Raw.eq_sym (s:=s) (s':=s'). + Definition eq_trans (s s' s'' : t) := + Raw.eq_trans (s:=s) (s':=s') (s'':=s''). + + Definition lt (s s' : t) := Raw.lt s s'. + Definition lt_trans (s s' s'' : t) := + Raw.lt_trans (s:=s) (s':=s') (s'':=s''). + Definition lt_not_eq (s s' : t) := Raw.lt_not_eq (sorted s) (sorted s'). + + Definition compare : forall s s' : t, Compare lt eq s s'. + Proof. + intros; elim (Raw.compare (sorted s) (sorted s')); + [ constructor 1 | constructor 2 | constructor 3 ]; + auto. + Defined. + +End Make. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v new file mode 100644 index 00000000..23843084 --- /dev/null +++ b/theories/FSets/FSetProperties.v @@ -0,0 +1,1007 @@ +(***********************************************************************) +(* 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: FSetProperties.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +(** * Finite sets library *) + +(** This functor derives additional properties from [FSetInterface.S]. + Contrary to the functor in [FSetEqProperties] it uses + predicates over sets instead of sets operations, i.e. + [In x s] instead of [mem x s=true], + [Equal s s'] instead of [equal s s'=true], etc. *) + +Require Export FSetInterface. +Require Import FSetFacts. +Set Implicit Arguments. +Unset Strict Implicit. + +Section Misc. +Variable A B : Set. +Variable eqA : A -> A -> Prop. +Variable eqB : B -> B -> Prop. + +(** Two-argument functions that allow to reorder its arguments. *) +Definition transpose (f : A -> B -> B) := + forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). + +(** Compatibility of a two-argument function with respect to two equalities. *) +Definition compat_op (f : A -> B -> B) := + forall (x x' : A) (y y' : B), eqA x x' -> eqB y y' -> eqB (f x y) (f x' y'). + +(** Compatibility of a function upon natural numbers. *) +Definition compat_nat (f : A -> nat) := + forall x x' : A, eqA x x' -> f x = f x'. + +End Misc. +Hint Unfold transpose compat_op compat_nat. + +Hint Extern 1 (Setoid_Theory _ _) => constructor; congruence. + +Ltac trans_st x := match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + apply (Seq_trans _ _ H) with x; auto + end. + +Ltac sym_st := match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + apply (Seq_sym _ _ H); auto + end. + +Ltac refl_st := match goal with + | H : Setoid_Theory _ ?eqA |- ?eqA _ _ => + apply (Seq_refl _ _ H); auto + end. + +Definition gen_st : forall A : Set, Setoid_Theory _ (@eq A). +Proof. auto. Qed. + +Module Properties (M: S). + Module ME := OrderedTypeFacts M.E. + Import ME. + Import M. + Import Logic. (* to unmask [eq] *) + Import Peano. (* to unmask [lt] *) + + (** Results about lists without duplicates *) + + Module FM := Facts M. + Import FM. + + Definition Add (x : elt) (s s' : t) := + forall y : elt, In y s' <-> E.eq x y \/ In y s. + + Lemma In_dec : forall x s, {In x s} + {~ In x s}. + Proof. + intros; generalize (mem_iff s x); case (mem x s); intuition. + Qed. + + Section BasicProperties. + Variable s s' s'' s1 s2 s3 : t. + Variable x : elt. + + (** properties of [Equal] *) + + Lemma equal_refl : s[=]s. + Proof. + apply eq_refl. + Qed. + + Lemma equal_sym : s[=]s' -> s'[=]s. + Proof. + apply eq_sym. + Qed. + + Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. + Proof. + intros; apply eq_trans with s2; auto. + Qed. + + (** properties of [Subset] *) + + Lemma subset_refl : s[<=]s. + Proof. + unfold Subset; intuition. + Qed. + + Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. + Proof. + unfold Subset, Equal; intuition. + Qed. + + Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. + Proof. + unfold Subset; intuition. + Qed. + + Lemma subset_equal : s[=]s' -> s[<=]s'. + Proof. + unfold Subset, Equal; firstorder. + Qed. + + Lemma subset_empty : empty[<=]s. + Proof. + unfold Subset; intros a; set_iff; intuition. + Qed. + + Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2. + Proof. + unfold Subset; intros H a; set_iff; intuition. + Qed. + + Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. + Proof. + unfold Subset; intros H a; set_iff; intuition. + Qed. + + Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. + Proof. + unfold Subset; intros H H0 a; set_iff; intuition. + rewrite <- H2; auto. + Qed. + + Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2. + Proof. + unfold Subset; intuition. + Qed. + + Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. + Proof. + unfold Subset; intuition. + Qed. + + (** properties of [empty] *) + + Lemma empty_is_empty_1 : Empty s -> s[=]empty. + Proof. + unfold Empty, Equal; intros; generalize (H a); set_iff; tauto. + Qed. + + Lemma empty_is_empty_2 : s[=]empty -> Empty s. + Proof. + unfold Empty, Equal; intros; generalize (H a); set_iff; tauto. + Qed. + + (** properties of [add] *) + + Lemma add_equal : In x s -> add x s [=] s. + Proof. + unfold Equal; intros; set_iff; intuition. + rewrite <- H1; auto. + Qed. + + (** properties of [remove] *) + + Lemma remove_equal : ~ In x s -> remove x s [=] s. + Proof. + unfold Equal; intros; set_iff; intuition. + rewrite H1 in H; auto. + Qed. + + Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'. + Proof. + intros; rewrite H; apply eq_refl. + Qed. + + (** properties of [add] and [remove] *) + + Lemma add_remove : In x s -> add x (remove x s) [=] s. + Proof. + unfold Equal; intros; set_iff; elim (eq_dec x a); intuition. + rewrite <- H1; auto. + Qed. + + Lemma remove_add : ~In x s -> remove x (add x s) [=] s. + Proof. + unfold Equal; intros; set_iff; elim (eq_dec x a); intuition. + rewrite H1 in H; auto. + Qed. + + (** properties of [singleton] *) + + Lemma singleton_equal_add : singleton x [=] add x empty. + Proof. + unfold Equal; intros; set_iff; intuition. + Qed. + + (** properties of [union] *) + + Lemma union_sym : union s s' [=] union s' s. + Proof. + unfold Equal; intros; set_iff; tauto. + Qed. + + Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'. + Proof. + unfold Subset, Equal; intros; set_iff; intuition. + Qed. + + Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''. + Proof. + intros; rewrite H; apply eq_refl. + Qed. + + Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. + Proof. + intros; rewrite H; apply eq_refl. + Qed. + + Lemma union_assoc : union (union s s') s'' [=] union s (union s' s''). + Proof. + unfold Equal; intros; set_iff; tauto. + Qed. + + Lemma add_union_singleton : add x s [=] union (singleton x) s. + Proof. + unfold Equal; intros; set_iff; tauto. + Qed. + + Lemma union_add : union (add x s) s' [=] add x (union s s'). + Proof. + unfold Equal; intros; set_iff; tauto. + Qed. + + Lemma union_subset_1 : s [<=] union s s'. + Proof. + unfold Subset; intuition. + Qed. + + Lemma union_subset_2 : s' [<=] union s s'. + Proof. + unfold Subset; intuition. + Qed. + + Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''. + Proof. + unfold Subset; intros H H0 a; set_iff; intuition. + Qed. + + Lemma empty_union_1 : Empty s -> union s s' [=] s'. + Proof. + unfold Equal, Empty; intros; set_iff; firstorder. + Qed. + + Lemma empty_union_2 : Empty s -> union s' s [=] s'. + Proof. + unfold Equal, Empty; intros; set_iff; firstorder. + Qed. + + Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). + Proof. + intros; set_iff; intuition. + Qed. + + (** properties of [inter] *) + + Lemma inter_sym : inter s s' [=] inter s' s. + Proof. + unfold Equal; intros; set_iff; tauto. + Qed. + + Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s. + Proof. + unfold Equal; intros; set_iff; intuition. + Qed. + + Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''. + Proof. + intros; rewrite H; apply eq_refl. + Qed. + + Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. + Proof. + intros; rewrite H; apply eq_refl. + Qed. + + Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s''). + Proof. + unfold Equal; intros; set_iff; tauto. + Qed. + + Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s''). + Proof. + unfold Equal; intros; set_iff; tauto. + Qed. + + Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s''). + Proof. + unfold Equal; intros; set_iff; tauto. + Qed. + + Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s'). + Proof. + unfold Equal; intros; set_iff; intuition. + rewrite <- H1; auto. + Qed. + + Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'. + Proof. + unfold Equal; intros; set_iff; intuition. + destruct H; rewrite H0; auto. + Qed. + + Lemma empty_inter_1 : Empty s -> Empty (inter s s'). + Proof. + unfold Empty; intros; set_iff; firstorder. + Qed. + + Lemma empty_inter_2 : Empty s' -> Empty (inter s s'). + Proof. + unfold Empty; intros; set_iff; firstorder. + Qed. + + Lemma inter_subset_1 : inter s s' [<=] s. + Proof. + unfold Subset; intro a; set_iff; tauto. + Qed. + + Lemma inter_subset_2 : inter s s' [<=] s'. + Proof. + unfold Subset; intro a; set_iff; tauto. + Qed. + + Lemma inter_subset_3 : + s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. + Proof. + unfold Subset; intros H H' a; set_iff; intuition. + Qed. + + (** properties of [diff] *) + + Lemma empty_diff_1 : Empty s -> Empty (diff s s'). + Proof. + unfold Empty, Equal; intros; set_iff; firstorder. + Qed. + + Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. + Proof. + unfold Empty, Equal; intros; set_iff; firstorder. + Qed. + + Lemma diff_subset : diff s s' [<=] s. + Proof. + unfold Subset; intros a; set_iff; tauto. + Qed. + + Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty. + Proof. + unfold Subset, Equal; intros; set_iff; intuition; absurd (In a empty); auto. + Qed. + + Lemma remove_diff_singleton : + remove x s [=] diff s (singleton x). + Proof. + unfold Equal; intros; set_iff; intuition. + Qed. + + Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. + Proof. + unfold Equal; intros; set_iff; intuition; absurd (In a empty); auto. + Qed. + + Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. + Proof. + unfold Equal; intros; set_iff; intuition. + elim (In_dec a s'); auto. + Qed. + + (** properties of [Add] *) + + Lemma Add_add : Add x s (add x s). + Proof. + unfold Add; intros; set_iff; intuition. + Qed. + + Lemma Add_remove : In x s -> Add x (remove x s) s. + Proof. + unfold Add; intros; set_iff; intuition. + elim (eq_dec x y); auto. + rewrite <- H1; auto. + Qed. + + Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). + Proof. + unfold Add; intros; set_iff; rewrite H; tauto. + Qed. + + Lemma inter_Add : + In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). + Proof. + unfold Add; intros; set_iff; rewrite H0; intuition. + rewrite <- H2; auto. + Qed. + + Lemma union_Equal : + In x s'' -> Add x s s' -> union s s'' [=] union s' s''. + Proof. + unfold Add, Equal; intros; set_iff; rewrite H0; intuition. + rewrite <- H1; auto. + Qed. + + Lemma inter_Add_2 : + ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. + Proof. + unfold Add, Equal; intros; set_iff; rewrite H0; intuition. + destruct H; rewrite H1; auto. + Qed. + + End BasicProperties. + + Hint Immediate equal_sym: set. + Hint Resolve equal_refl equal_trans : set. + + Hint Immediate add_remove remove_add union_sym inter_sym: set. + Hint Resolve subset_refl subset_equal subset_antisym + subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 + subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal + remove_equal singleton_equal_add union_subset_equal union_equal_1 + union_equal_2 union_assoc add_union_singleton union_add union_subset_1 + union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2 + inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2 + empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 + empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union + inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal + remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove + Equal_remove : set. + + Notation NoDup := (NoDupA E.eq). + Notation EqList := (eqlistA E.eq). + + Section NoDupA_Remove. + + Let ListAdd x l l' := forall y : elt, ME.In y l' <-> E.eq x y \/ ME.In y l. + + Lemma removeA_add : + forall s s' x x', NoDup s -> NoDup (x' :: s') -> + ~ E.eq x x' -> ~ ME.In x s -> + ListAdd x s (x' :: s') -> ListAdd x (removeA eq_dec x' s) s'. + Proof. + unfold ListAdd; intros. + inversion_clear H0. + rewrite removeA_InA; auto; [apply E.eq_trans|]. + split; intros. + destruct (eq_dec x y); auto; intros. + right; split; auto. + destruct (H3 y); clear H3. + destruct H6; intuition. + swap H4; apply In_eq with y; auto. + destruct H0. + assert (ME.In y (x' :: s')) by rewrite H3; auto. + inversion_clear H6; auto. + elim H1; apply E.eq_trans with y; auto. + destruct H0. + assert (ME.In y (x' :: s')) by rewrite H3; auto. + inversion_clear H7; auto. + elim H6; auto. + Qed. + + Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). + Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). + Variables (i:A). + + Lemma removeA_fold_right_0 : + forall s x, NoDup s -> ~ME.In x s -> + eqA (fold_right f i s) (fold_right f i (removeA eq_dec x s)). + Proof. + simple induction s; simpl; intros. + refl_st. + inversion_clear H0. + destruct (eq_dec x a); simpl; intros. + absurd_hyp e; auto. + apply Comp; auto. + Qed. + + Lemma removeA_fold_right : + forall s x, NoDup s -> ME.In x s -> + eqA (fold_right f i s) (f x (fold_right f i (removeA eq_dec x s))). + Proof. + simple induction s; simpl. + inversion_clear 2. + intros. + inversion_clear H0. + destruct (eq_dec x a); simpl; intros. + apply Comp; auto. + apply removeA_fold_right_0; auto. + swap H2; apply ME.In_eq with x; auto. + inversion_clear H1. + destruct n; auto. + trans_st (f a (f x (fold_right f i (removeA eq_dec x l)))). + Qed. + + Lemma fold_right_equal : + forall s s', NoDup s -> NoDup s' -> + EqList s s' -> eqA (fold_right f i s) (fold_right f i s'). + Proof. + simple induction s. + destruct s'; simpl. + intros; refl_st; auto. + unfold eqlistA; intros. + destruct (H1 t0). + assert (X : ME.In t0 nil); auto; inversion X. + intros x l Hrec s' N N' E; simpl in *. + trans_st (f x (fold_right f i (removeA eq_dec x s'))). + apply Comp; auto. + apply Hrec; auto. + inversion N; auto. + apply removeA_NoDupA; auto; apply E.eq_trans. + apply removeA_eqlistA; auto; [apply E.eq_trans|]. + inversion_clear N; auto. + sym_st. + apply removeA_fold_right; auto. + unfold eqlistA in E. + rewrite <- E; auto. + Qed. + + Lemma fold_right_add : + forall s' s x, NoDup s -> NoDup s' -> ~ ME.In x s -> + ListAdd x s s' -> eqA (fold_right f i s') (f x (fold_right f i s)). + Proof. + simple induction s'. + unfold ListAdd; intros. + destruct (H2 x); clear H2. + assert (X : ME.In x nil); auto; inversion X. + intros x' l' Hrec s x N N' IN EQ; simpl. + (* if x=x' *) + destruct (eq_dec x x'). + apply Comp; auto. + apply fold_right_equal; auto. + inversion_clear N'; trivial. + unfold eqlistA; unfold ListAdd in EQ; intros. + destruct (EQ x0); clear EQ. + split; intros. + destruct H; auto. + inversion_clear N'. + destruct H2; apply In_eq with x0; auto; order. + assert (X:ME.In x0 (x' :: l')); auto; inversion_clear X; auto. + destruct IN; apply In_eq with x0; auto; order. + (* else x<>x' *) + trans_st (f x' (f x (fold_right f i (removeA eq_dec x' s)))). + apply Comp; auto. + apply Hrec; auto. + apply removeA_NoDupA; auto; apply E.eq_trans. + inversion_clear N'; auto. + rewrite removeA_InA; auto; [apply E.eq_trans|intuition]. + apply removeA_add; auto. + trans_st (f x (f x' (fold_right f i (removeA eq_dec x' s)))). + apply Comp; auto. + sym_st. + apply removeA_fold_right; auto. + destruct (EQ x'). + destruct H; auto; destruct n; auto. + Qed. + + End NoDupA_Remove. + + (** * Alternative (weaker) specifications for [fold] *) + + Section Old_Spec_Now_Properties. + + (** When [FSets] was first designed, the order in which Ocaml's [Set.fold] + takes the set elements was unspecified. This specification reflects this fact: + *) + + Lemma fold_0 : + forall s (A : Set) (i : A) (f : elt -> A -> A), + exists l : list elt, + NoDup l /\ + (forall x : elt, In x s <-> InA E.eq x l) /\ + fold f s i = fold_right f i l. + Proof. + intros; exists (rev (elements s)); split. + apply NoDupA_rev; auto. + exact E.eq_trans. + split; intros. + rewrite elements_iff; do 2 rewrite InA_alt. + split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. + rewrite fold_left_rev_right. + apply fold_1. + Qed. + + (** An alternate (and previous) specification for [fold] was based on + the recursive structure of a set. It is now lemmas [fold_1] and + [fold_2]. *) + + Lemma fold_1 : + forall s (A : Set) (eqA : A -> A -> Prop) + (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), + Empty s -> eqA (fold f s i) i. + Proof. + unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). + rewrite H3; clear H3. + generalize H H2; clear H H2; case l; simpl; intros. + refl_st. + elim (H e). + elim (H2 e); intuition. + Qed. + + Lemma fold_2 : + forall s s' x (A : Set) (eqA : A -> A -> Prop) + (st : Setoid_Theory A eqA) (i : A) (f : elt -> A -> A), + compat_op E.eq eqA f -> + transpose eqA f -> + ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). + Proof. + intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); + destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). + rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. + apply fold_right_add with (eqA := eqA); auto. + rewrite <- Hl1; auto. + intros; rewrite <- Hl1; rewrite <- Hl'1; auto. + Qed. + + (** Similar specifications for [cardinal]. *) + + Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. + Proof. + intros; rewrite cardinal_1; rewrite M.fold_1. + symmetry; apply fold_left_length; auto. + Qed. + + Lemma cardinal_0 : + forall s, exists l : list elt, + NoDupA E.eq l /\ + (forall x : elt, In x s <-> InA E.eq x l) /\ + cardinal s = length l. + Proof. + intros; exists (elements s); intuition; apply cardinal_1. + Qed. + + Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. + Proof. + intros; rewrite cardinal_fold; apply fold_1; auto. + Qed. + + Lemma cardinal_2 : + forall s s' x, ~ In x s -> Add x s s' -> cardinal s' = S (cardinal s). + Proof. + intros; do 2 rewrite cardinal_fold. + change S with ((fun _ => S) x). + apply fold_2; auto. + Qed. + + End Old_Spec_Now_Properties. + + (** * Induction principle over sets *) + + Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. + Proof. + intros s; rewrite M.cardinal_1; intros H a; red. + rewrite elements_iff. + destruct (elements s); simpl in *; discriminate || inversion 1. + Qed. + Hint Resolve cardinal_inv_1. + + Lemma cardinal_inv_2 : + forall s n, cardinal s = S n -> { x : elt | In x s }. + Proof. + intros; rewrite M.cardinal_1 in H. + generalize (elements_2 (s:=s)). + destruct (elements s); try discriminate. + exists e; auto. + Qed. + + Lemma Equal_cardinal_aux : + forall n s s', cardinal s = n -> s[=]s' -> cardinal s = cardinal s'. + Proof. + simple induction n; intros. + rewrite H; symmetry . + apply cardinal_1. + rewrite <- H0; auto. + destruct (cardinal_inv_2 H0) as (x,H2). + revert H0. + rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. + rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); auto with set. + rewrite H1 in H2; auto with set. + Qed. + + Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. + Proof. + intros; apply Equal_cardinal_aux with (cardinal s); auto. + Qed. + + Add Morphism cardinal : cardinal_m. + Proof. + exact Equal_cardinal. + Qed. + + Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. + + Lemma cardinal_induction : + forall P : t -> Type, + (forall s, Empty s -> P s) -> + (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> + forall n s, cardinal s = n -> P s. + Proof. + simple induction n; intros; auto. + destruct (cardinal_inv_2 H) as (x,H0). + apply X0 with (remove x s) x; auto. + apply X1; auto. + rewrite (cardinal_2 (x:=x)(s:=remove x s)(s':=s)) in H; auto. + Qed. + + Lemma set_induction : + forall P : t -> Type, + (forall s : t, Empty s -> P s) -> + (forall s s' : t, P s -> forall x : elt, ~In x s -> Add x s s' -> P s') -> + forall s : t, P s. + Proof. + intros; apply cardinal_induction with (cardinal s); auto. + Qed. + + (** Other properties of [fold]. *) + + Section Fold. + Variables (A:Set)(eqA:A->A->Prop)(st:Setoid_Theory _ eqA). + Variables (f:elt->A->A)(Comp:compat_op E.eq eqA f)(Ass:transpose eqA f). + + Section Fold_1. + Variable i i':A. + + Lemma fold_empty : eqA (fold f empty i) i. + Proof. + apply fold_1; auto. + Qed. + + Lemma fold_equal : + forall s s', s[=]s' -> eqA (fold f s i) (fold f s' i). + Proof. + intros s; pattern s; apply set_induction; clear s; intros. + trans_st i. + apply fold_1; auto. + sym_st; apply fold_1; auto. + rewrite <- H0; auto. + trans_st (f x (fold f s i)). + apply fold_2 with (eqA := eqA); auto. + sym_st; apply fold_2 with (eqA := eqA); auto. + unfold Add in *; intros. + rewrite <- H2; auto. + Qed. + + Lemma fold_add : forall s x, ~In x s -> + eqA (fold f (add x s) i) (f x (fold f s i)). + Proof. + intros; apply fold_2 with (eqA := eqA); auto. + Qed. + + Lemma add_fold : forall 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 s x, In x s -> + eqA (f x (fold f (remove x s) i)) (fold f s i). + Proof. + intros. + sym_st. + apply fold_2 with (eqA:=eqA); auto. + Qed. + + Lemma remove_fold_2: forall s x, ~In x s -> + eqA (fold f (remove x s) i) (fold f s i). + Proof. + intros. + apply fold_equal; auto with set. + Qed. + + Lemma fold_commutes : forall s x, + eqA (fold f s (f x i)) (f x (fold f s i)). + Proof. + intros; pattern s; apply set_induction; clear s; intros. + trans_st (f x i). + apply fold_1; auto. + sym_st. + apply Comp; auto. + apply fold_1; auto. + trans_st (f x0 (fold f s (f x i))). + apply fold_2 with (eqA:=eqA); auto. + trans_st (f x0 (f x (fold f s i))). + trans_st (f x (f x0 (fold f s i))). + apply Comp; auto. + sym_st. + apply fold_2 with (eqA:=eqA); auto. + Qed. + + Lemma fold_init : forall s, eqA i i' -> + eqA (fold f s i) (fold f s i'). + Proof. + intros; pattern s; apply set_induction; clear s; intros. + trans_st i. + apply fold_1; auto. + trans_st i'. + sym_st; apply fold_1; auto. + trans_st (f x (fold f s i)). + apply fold_2 with (eqA:=eqA); auto. + trans_st (f x (fold f s i')). + sym_st; apply fold_2 with (eqA:=eqA); auto. + Qed. + + End Fold_1. + Section Fold_2. + Variable i:A. + + Lemma fold_union_inter : forall s s', + eqA (fold f (union s s') (fold f (inter s s') i)) + (fold f s (fold f s' i)). + Proof. + intros; pattern s; apply set_induction; clear s; intros. + trans_st (fold f s' (fold f (inter s s') i)). + apply fold_equal; auto with set. + trans_st (fold f s' i). + apply fold_init; auto. + apply fold_1; auto with set. + sym_st; apply fold_1; auto. + rename s'0 into s''. + destruct (In_dec x s'). + (* In x s' *) + trans_st (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. + apply fold_init; auto. + apply fold_2 with (eqA:=eqA); auto with set. + rewrite inter_iff; intuition. + trans_st (f x (fold f s (fold f s' i))). + trans_st (fold f (union s s') (f x (fold f (inter s s') i))). + apply fold_equal; auto. + apply equal_sym; apply union_Equal with x; auto with set. + trans_st (f x (fold f (union s s') (fold f (inter s s') i))). + apply fold_commutes; auto. + sym_st; apply fold_2 with (eqA:=eqA); auto. + (* ~(In x s') *) + trans_st (f x (fold f (union s s') (fold f (inter s'' s') i))). + apply fold_2 with (eqA:=eqA); auto with set. + trans_st (f x (fold f (union s s') (fold f (inter s s') i))). + apply Comp;auto. + apply fold_init;auto. + apply fold_equal;auto. + apply equal_sym; apply inter_Add_2 with x; auto with set. + trans_st (f x (fold f s (fold f s' i))). + sym_st; apply fold_2 with (eqA:=eqA); auto. + Qed. + + End Fold_2. + Section Fold_3. + Variable i:A. + + Lemma fold_diff_inter : forall s s', + eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). + Proof. + intros. + trans_st (fold f (union (diff s s') (inter s s')) + (fold f (inter (diff s s') (inter s s')) i)). + sym_st; apply fold_union_inter; auto. + trans_st (fold f s (fold f (inter (diff s s') (inter s s')) i)). + apply fold_equal; auto with set. + apply fold_init; auto. + apply fold_1; auto with set. + Qed. + + Lemma fold_union: forall s s', (forall x, ~In x s\/~In x s') -> + eqA (fold f (union s s') i) (fold f s (fold f s' i)). + Proof. + intros. + trans_st (fold f (union s s') (fold f (inter s s') i)). + apply fold_init; auto. + sym_st; apply fold_1; auto with set. + unfold Empty; intro a; generalize (H a); set_iff; tauto. + apply fold_union_inter; auto. + Qed. + + End Fold_3. + End Fold. + + Lemma fold_plus : + forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. + Proof. + assert (st := gen_st nat). + assert (fe : compat_op E.eq (@eq _) (fun _ => S)) by unfold compat_op; auto. + assert (fp : transpose (@eq _) (fun _:elt => S)) by unfold transpose; auto. + intros s p; pattern s; apply set_induction; clear s; intros. + rewrite (fold_1 st p (fun _ => S) H). + rewrite (fold_1 st 0 (fun _ => S) H); trivial. + assert (forall p s', Add x s s' -> fold (fun _ => S) s' p = S (fold (fun _ => S) s p)). + change S with ((fun _ => S) x). + intros; apply fold_2; auto. + rewrite H2; auto. + rewrite (H2 0); auto. + rewrite H. + simpl; auto. + Qed. + + (** properties of [cardinal] *) + + Lemma empty_cardinal : cardinal empty = 0. + Proof. + rewrite cardinal_fold; apply fold_1; auto. + Qed. + + Hint Immediate empty_cardinal cardinal_1 : set. + + Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. + Proof. + intros. + rewrite (singleton_equal_add x). + replace 0 with (cardinal empty); auto with set. + apply cardinal_2 with x; auto with set. + Qed. + + Hint Resolve singleton_cardinal: set. + + Lemma diff_inter_cardinal : + forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s . + Proof. + intros; do 3 rewrite cardinal_fold. + rewrite <- fold_plus. + apply fold_diff_inter with (eqA:=@eq nat); auto. + Qed. + + Lemma union_cardinal: + forall s s', (forall x, ~In x s\/~In x s') -> + cardinal (union s s')=cardinal s+cardinal s'. + Proof. + intros; do 3 rewrite cardinal_fold. + rewrite <- fold_plus. + apply fold_union; auto. + Qed. + + Lemma subset_cardinal : + forall s s', s[<=]s' -> cardinal s <= cardinal s' . + Proof. + intros. + rewrite <- (diff_inter_cardinal s' s). + rewrite (inter_sym s' s). + rewrite (inter_subset_equal H); auto with arith. + Qed. + + Lemma union_inter_cardinal : + forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . + Proof. + intros. + do 4 rewrite cardinal_fold. + do 2 rewrite <- fold_plus. + apply fold_union_inter with (eqA:=@eq nat); auto. + Qed. + + Lemma union_cardinal_le : + forall s s', cardinal (union s s') <= cardinal s + cardinal s'. + Proof. + intros; generalize (union_inter_cardinal s s'). + intros; rewrite <- H; auto with arith. + Qed. + + Lemma add_cardinal_1 : + forall s x, In x s -> cardinal (add x s) = cardinal s. + Proof. + auto with set. + Qed. + + Lemma add_cardinal_2 : + forall s x, ~In x s -> cardinal (add x s) = S (cardinal s). + Proof. + intros. + do 2 rewrite cardinal_fold. + change S with ((fun _ => S) x); + apply fold_add with (eqA:=@eq nat); auto. + Qed. + + Lemma remove_cardinal_1 : + forall s x, In x s -> S (cardinal (remove x s)) = cardinal s. + Proof. + intros. + do 2 rewrite cardinal_fold. + change S with ((fun _ =>S) x). + apply remove_fold_1 with (eqA:=@eq nat); auto. + Qed. + + Lemma remove_cardinal_2 : + forall s x, ~In x s -> cardinal (remove x s) = cardinal s. + Proof. + auto with set. + Qed. + + Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2. + +End Properties. diff --git a/theories/FSets/FSetWeak.v b/theories/FSets/FSetWeak.v new file mode 100644 index 00000000..7ed61c9f --- /dev/null +++ b/theories/FSets/FSetWeak.v @@ -0,0 +1,14 @@ +(***********************************************************************) +(* 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: FSetWeak.v 8641 2006-03-17 09:56:54Z letouzey $ *) + +Require Export DecidableType. +Require Export FSetWeakInterface. +Require Export FSetFacts. +Require Export FSetWeakList. diff --git a/theories/FSets/FSetWeakFacts.v b/theories/FSets/FSetWeakFacts.v new file mode 100644 index 00000000..46a73cc9 --- /dev/null +++ b/theories/FSets/FSetWeakFacts.v @@ -0,0 +1,415 @@ +(***********************************************************************) +(* 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: FSetWeakFacts.v 8681 2006-04-05 11:56:14Z letouzey $ *) + +(** * Finite sets library *) + +(** This functor derives additional facts from [FSetInterface.S]. These + facts are mainly the specifications of [FSetInterface.S] written using + different styles: equivalence and boolean equalities. + Moreover, we prove that [E.Eq] and [Equal] are setoid equalities. +*) + +Require Export FSetWeakInterface. +Set Implicit Arguments. +Unset Strict Implicit. + +Module Facts (M: S). +Import M.E. +Import M. +Import Logic. (* to unmask [eq] *) + +(** * Specifications written using equivalences *) + +Section IffSpec. +Variable s s' s'' : t. +Variable x y z : elt. + +Lemma In_eq_iff : E.eq x y -> (In x s <-> In y s). +Proof. +split; apply In_1; auto. +Qed. + +Lemma mem_iff : In x s <-> mem x s = true. +Proof. +split; [apply mem_1|apply mem_2]. +Qed. + +Lemma not_mem_iff : ~In x s <-> mem x s = false. +Proof. +rewrite mem_iff; destruct (mem x s); intuition. +Qed. + +Lemma equal_iff : s[=]s' <-> equal s s' = true. +Proof. +split; [apply equal_1|apply equal_2]. +Qed. + +Lemma subset_iff : s[<=]s' <-> subset s s' = true. +Proof. +split; [apply subset_1|apply subset_2]. +Qed. + +Lemma empty_iff : In x empty <-> False. +Proof. +intuition; apply (empty_1 H). +Qed. + +Lemma is_empty_iff : Empty s <-> is_empty s = true. +Proof. +split; [apply is_empty_1|apply is_empty_2]. +Qed. + +Lemma singleton_iff : In y (singleton x) <-> E.eq x y. +Proof. +split; [apply singleton_1|apply singleton_2]. +Qed. + +Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. +Proof. +split; [ | destruct 1; [apply add_1|apply add_2]]; auto. +destruct (eq_dec x y) as [E|E]; auto. +intro H; right; exact (add_3 E H). +Qed. + +Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s) <-> In y s). +Proof. +split; [apply add_3|apply add_2]; auto. +Qed. + +Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y. +Proof. +split; [split; [apply remove_3 with x |] | destruct 1; apply remove_2]; auto. +intro. +apply (remove_1 H0 H). +Qed. + +Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s). +Proof. +split; [apply remove_3|apply remove_2]; auto. +Qed. + +Lemma union_iff : In x (union s s') <-> In x s \/ In x s'. +Proof. +split; [apply union_1 | destruct 1; [apply union_2|apply union_3]]; auto. +Qed. + +Lemma inter_iff : In x (inter s s') <-> In x s /\ In x s'. +Proof. +split; [split; [apply inter_1 with s' | apply inter_2 with s] | destruct 1; apply inter_3]; auto. +Qed. + +Lemma diff_iff : In x (diff s s') <-> In x s /\ ~ In x s'. +Proof. +split; [split; [apply diff_1 with s' | apply diff_2 with s] | destruct 1; apply diff_3]; auto. +Qed. + +Variable f : elt->bool. + +Lemma filter_iff : compat_bool E.eq f -> (In x (filter f s) <-> In x s /\ f x = true). +Proof. +split; [split; [apply filter_1 with f | apply filter_2 with s] | destruct 1; apply filter_3]; auto. +Qed. + +Lemma for_all_iff : compat_bool E.eq f -> + (For_all (fun x => f x = true) s <-> for_all f s = true). +Proof. +split; [apply for_all_1 | apply for_all_2]; auto. +Qed. + +Lemma exists_iff : compat_bool E.eq f -> + (Exists (fun x => f x = true) s <-> exists_ f s = true). +Proof. +split; [apply exists_1 | apply exists_2]; auto. +Qed. + +Lemma elements_iff : In x s <-> InA E.eq x (elements s). +Proof. +split; [apply elements_1 | apply elements_2]. +Qed. + +End IffSpec. + +(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) + +Ltac set_iff := + repeat (progress ( + rewrite add_iff || rewrite remove_iff || rewrite singleton_iff + || rewrite union_iff || rewrite inter_iff || rewrite diff_iff + || rewrite empty_iff)). + +(** * Specifications written using boolean predicates *) + +Definition eqb x y := if eq_dec x y then true else false. + +Section BoolSpec. +Variable s s' s'' : t. +Variable x y z : elt. + +Lemma mem_b : E.eq x y -> mem x s = mem y s. +Proof. +intros. +generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). +destruct (mem x s); destruct (mem y s); intuition. +Qed. + +Lemma add_b : mem y (add x s) = eqb x y || mem y s. +Proof. +generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb. +destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition. +Qed. + +Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s. +Proof. +intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H). +destruct (mem y s); destruct (mem y (add x s)); intuition. +Qed. + +Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y). +Proof. +generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb. +destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition. +Qed. + +Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s. +Proof. +intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H). +destruct (mem y s); destruct (mem y (remove x s)); intuition. +Qed. + +Lemma singleton_b : mem y (singleton x) = eqb x y. +Proof. +generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. +destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. +Qed. + +Lemma union_b : mem x (union s s') = mem x s || mem x s'. +Proof. +generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x). +destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition. +Qed. + +Lemma inter_b : mem x (inter s s') = mem x s && mem x s'. +Proof. +generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x). +destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition. +Qed. + +Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s'). +Proof. +generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x). +destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition. +Qed. + +Lemma elements_b : mem x s = existsb (eqb x) (elements s). +Proof. +generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)). +rewrite InA_alt. +destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros. +symmetry. +rewrite H1. +destruct H0 as (H0,_). +destruct H0 as (a,(Ha1,Ha2)); [ intuition |]. +exists a; intuition. +unfold eqb; destruct (eq_dec x a); auto. +rewrite <- H. +rewrite H0. +destruct H1 as (H1,_). +destruct H1 as (a,(Ha1,Ha2)); [intuition|]. +exists a; intuition. +unfold eqb in *; destruct (eq_dec x a); auto; discriminate. +Qed. + +Variable f : elt->bool. + +Lemma filter_b : compat_bool E.eq f -> mem x (filter f s) = mem x s && f x. +Proof. +intros. +generalize (mem_iff (filter f s) x)(mem_iff s x)(filter_iff s x H). +destruct (mem x s); destruct (mem x (filter f s)); destruct (f x); simpl; intuition. +Qed. + +Lemma for_all_b : compat_bool E.eq f -> + for_all f s = forallb f (elements s). +Proof. +intros. +generalize (forallb_forall f (elements s))(for_all_iff s H)(elements_iff s). +unfold For_all. +destruct (forallb f (elements s)); destruct (for_all f s); auto; intros. +rewrite <- H1; intros. +destruct H0 as (H0,_). +rewrite (H2 x0) in H3. +rewrite (InA_alt E.eq x0 (elements s)) in H3. +destruct H3 as (a,(Ha1,Ha2)). +rewrite (H _ _ Ha1). +apply H0; auto. +symmetry. +rewrite H0; intros. +destruct H1 as (_,H1). +apply H1; auto. +rewrite H2. +rewrite InA_alt; eauto. +Qed. + +Lemma exists_b : compat_bool E.eq f -> + exists_ f s = existsb f (elements s). +Proof. +intros. +generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s). +unfold Exists. +destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. +rewrite <- H1; intros. +destruct H0 as (H0,_). +destruct H0 as (a,(Ha1,Ha2)); auto. +exists a; auto. +split; auto. +rewrite H2; rewrite InA_alt; eauto. +symmetry. +rewrite H0. +destruct H1 as (_,H1). +destruct H1 as (a,(Ha1,Ha2)); auto. +rewrite (H2 a) in Ha1. +rewrite (InA_alt E.eq a (elements s)) in Ha1. +destruct Ha1 as (b,(Hb1,Hb2)). +exists b; auto. +rewrite <- (H _ _ Hb1); auto. +Qed. + +End BoolSpec. + +(** * [E.eq] and [Equal] are setoid equalities *) + +Definition E_ST : Setoid_Theory elt E.eq. +Proof. +constructor; [apply E.eq_refl|apply E.eq_sym|apply E.eq_trans]. +Qed. + +Add Setoid elt E.eq E_ST as EltSetoid. + +Definition Equal_ST : Setoid_Theory t Equal. +Proof. +constructor; unfold Equal; firstorder. +Qed. + +Add Setoid t Equal Equal_ST as EqualSetoid. + +Add Morphism In with signature E.eq ==> Equal ==> iff as In_m. +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. +Proof. +unfold Equal; intros s s' H. +generalize (is_empty_iff s)(is_empty_iff s'). +destruct (is_empty s); destruct (is_empty s'); + unfold Empty; auto; intros. +symmetry. +rewrite <- H1; intros a Ha. +rewrite <- (H a) in Ha. +destruct H0 as (_,H0). +exact (H0 (refl_equal true) _ Ha). +rewrite <- H0; intros a Ha. +rewrite (H a) in Ha. +destruct H1 as (_,H1). +exact (H1 (refl_equal true) _ Ha). +Qed. + +Add Morphism Empty with signature Equal ==> iff as Empty_m. +Proof. +intros; do 2 rewrite is_empty_iff; rewrite H; intuition. +Qed. + +Add Morphism mem : mem_m. +Proof. +unfold Equal; intros x y H s s' H0. +generalize (H0 x); clear H0; rewrite (In_eq_iff s' H). +generalize (mem_iff s x)(mem_iff s' y). +destruct (mem x s); destruct (mem y s'); intuition. +Qed. + +Add Morphism singleton : singleton_m. +Proof. +unfold Equal; intros x y H a. +do 2 rewrite singleton_iff; split. +intros; apply E.eq_trans with x; auto. +intros; apply E.eq_trans with y; auto. +Qed. + +Add Morphism add : add_m. +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. +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. +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. +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. +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. +unfold Equal, Subset; firstorder. +Qed. + +Add Morphism subset : subset_m. +Proof. +intros s s' H s'' s''' H0. +generalize (subset_iff s s'') (subset_iff s' s'''). +destruct (subset s s''); destruct (subset s' s'''); auto; intros. +rewrite H in H1; rewrite H0 in H1; intuition. +rewrite H in H1; rewrite H0 in H1; intuition. +Qed. + +Add Morphism equal : equal_m. +Proof. +intros s s' H s'' s''' H0. +generalize (equal_iff s s'') (equal_iff s' s'''). +destruct (equal s s''); destruct (equal s' s'''); auto; intros. +rewrite H in H1; rewrite H0 in H1; intuition. +rewrite H in H1; rewrite H0 in H1; intuition. +Qed. + +(* [fold], [filter], [for_all], [exists_] and [partition] cannot be proved morphism + without additional hypothesis on [f]. For instance: *) + +Lemma filter_equal : forall f, compat_bool E.eq f -> + forall s s', s[=]s' -> filter f s [=] filter f s'. +Proof. +unfold Equal; intros; repeat rewrite filter_iff; auto; rewrite H0; tauto. +Qed. + +(* For [elements], [min_elt], [max_elt] and [choose], we would need setoid + structures on [list elt] and [option elt]. *) + +(* Later: +Add Morphism cardinal ; cardinal_m. +*) + +End Facts. diff --git a/theories/FSets/FSetWeakInterface.v b/theories/FSets/FSetWeakInterface.v new file mode 100644 index 00000000..c1845494 --- /dev/null +++ b/theories/FSets/FSetWeakInterface.v @@ -0,0 +1,248 @@ +(***********************************************************************) +(* 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: FSetWeakInterface.v 8641 2006-03-17 09:56:54Z letouzey $ *) + +(** * Finite sets library *) + +(** Set interfaces for types with only a decidable equality, but no ordering *) + +Require Export Bool. +Require Export DecidableType. +Set Implicit Arguments. +Unset Strict Implicit. + +(** Compatibility of a boolean function with respect to an equality. *) +Definition compat_bool (A:Set)(eqA: A->A->Prop)(f: A-> bool) := + forall x y : A, eqA x y -> f x = f y. + +(** Compatibility of a predicate with respect to an equality. *) +Definition compat_P (A:Set)(eqA: A->A->Prop)(P : A -> Prop) := + forall x y : A, eqA x y -> P x -> P y. + +Hint Unfold compat_bool compat_P. + +(** * Non-dependent signature + + Signature [S] presents sets as purely informative programs + together with axioms *) + +Module Type S. + + Declare Module E : DecidableType. + Definition elt := E.t. + + Parameter t : Set. (** the abstract type of sets *) + + (** Logical predicates *) + Parameter In : elt -> t -> Prop. + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + + Parameter empty : t. + (** The empty set. *) + + Parameter is_empty : t -> bool. + (** Test whether a set is empty or not. *) + + Parameter mem : elt -> t -> bool. + (** [mem x s] tests whether [x] belongs to the set [s]. *) + + Parameter add : elt -> t -> t. + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + + Parameter singleton : elt -> t. + (** [singleton x] returns the one-element set containing only [x]. *) + + Parameter remove : elt -> t -> t. + (** [remove x s] returns a set containing all elements of [s], + except [x]. If [x] was not in [s], [s] is returned unchanged. *) + + Parameter union : t -> t -> t. + (** Set union. *) + + Parameter inter : t -> t -> t. + (** Set intersection. *) + + Parameter diff : t -> t -> t. + (** Set difference. *) + + Parameter equal : t -> t -> bool. + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + + Parameter subset : t -> t -> bool. + (** [subset s1 s2] tests whether the set [s1] is a subset of + the set [s2]. *) + + (** Coq comment: [iter] is useless in a purely functional world *) + (** iter: (elt -> unit) -> set -> unit. i*) + (** [iter f s] applies [f] in turn to all elements of [s]. + The order in which the elements of [s] are presented to [f] + is unspecified. *) + + Parameter fold : forall A : Set, (elt -> A -> A) -> t -> A -> A. + (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], + where [x1 ... xN] are the elements of [s]. + The order in which elements of [s] are presented to [f] is + unspecified. *) + + Parameter for_all : (elt -> bool) -> t -> bool. + (** [for_all p s] checks if all elements of the set + satisfy the predicate [p]. *) + + Parameter exists_ : (elt -> bool) -> t -> bool. + (** [exists p s] checks if at least one element of + the set satisfies the predicate [p]. *) + + Parameter filter : (elt -> bool) -> t -> t. + (** [filter p s] returns the set of all elements in [s] + that satisfy predicate [p]. *) + + Parameter partition : (elt -> bool) -> t -> t * t. + (** [partition p s] returns a pair of sets [(s1, s2)], where + [s1] is the set of all the elements of [s] that satisfy the + predicate [p], and [s2] is the set of all the elements of + [s] that do not satisfy [p]. *) + + Parameter cardinal : t -> nat. + (** Return the number of elements of a set. *) + (** Coq comment: nat instead of int ... *) + + Parameter elements : t -> list elt. + (** Return the list of all elements of the given set, in any order. *) + + Parameter choose : t -> option elt. + (** Return one element of the given set, or raise [Not_found] if + the set is empty. Which element is chosen is unspecified. + Equal sets could return different elements. *) + (** Coq comment: [Not_found] is represented by the option type *) + + Section Spec. + + Variable s s' s'' : t. + Variable x y z : elt. + + (** Specification of [In] *) + Parameter In_1 : E.eq x y -> In x s -> In y s. + + (** Specification of [mem] *) + Parameter mem_1 : In x s -> mem x s = true. + Parameter mem_2 : mem x s = true -> In x s. + + (** Specification of [equal] *) + Parameter equal_1 : Equal s s' -> equal s s' = true. + Parameter equal_2 : equal s s' = true -> Equal s s'. + + (** Specification of [subset] *) + Parameter subset_1 : Subset s s' -> subset s s' = true. + Parameter subset_2 : subset s s' = true -> Subset s s'. + + (** Specification of [empty] *) + Parameter empty_1 : Empty empty. + + (** Specification of [is_empty] *) + Parameter is_empty_1 : Empty s -> is_empty s = true. + Parameter is_empty_2 : is_empty s = true -> Empty s. + + (** Specification of [add] *) + Parameter add_1 : E.eq x y -> In y (add x s). + Parameter add_2 : In y s -> In y (add x s). + Parameter add_3 : ~ E.eq x y -> In y (add x s) -> In y s. + + (** Specification of [remove] *) + Parameter remove_1 : E.eq x y -> ~ In y (remove x s). + Parameter remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). + Parameter remove_3 : In y (remove x s) -> In y s. + + (** Specification of [singleton] *) + Parameter singleton_1 : In y (singleton x) -> E.eq x y. + Parameter singleton_2 : E.eq x y -> In y (singleton x). + + (** Specification of [union] *) + Parameter union_1 : In x (union s s') -> In x s \/ In x s'. + Parameter union_2 : In x s -> In x (union s s'). + Parameter union_3 : In x s' -> In x (union s s'). + + (** Specification of [inter] *) + Parameter inter_1 : In x (inter s s') -> In x s. + Parameter inter_2 : In x (inter s s') -> In x s'. + Parameter inter_3 : In x s -> In x s' -> In x (inter s s'). + + (** Specification of [diff] *) + Parameter diff_1 : In x (diff s s') -> In x s. + Parameter diff_2 : In x (diff s s') -> ~ In x s'. + Parameter diff_3 : In x s -> ~ In x s' -> In x (diff s s'). + + (** Specification of [fold] *) + Parameter fold_1 : forall (A : Set) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + + (** Specification of [cardinal] *) + Parameter cardinal_1 : cardinal s = length (elements s). + + Section Filter. + + Variable f : elt -> bool. + + (** Specification of [filter] *) + Parameter filter_1 : compat_bool E.eq f -> In x (filter f s) -> In x s. + Parameter filter_2 : compat_bool E.eq f -> In x (filter f s) -> f x = true. + Parameter filter_3 : + compat_bool E.eq f -> In x s -> f x = true -> In x (filter f s). + + (** Specification of [for_all] *) + Parameter for_all_1 : + compat_bool E.eq f -> + For_all (fun x => f x = true) s -> for_all f s = true. + Parameter for_all_2 : + compat_bool E.eq f -> + for_all f s = true -> For_all (fun x => f x = true) s. + + (** Specification of [exists] *) + Parameter exists_1 : + compat_bool E.eq f -> + Exists (fun x => f x = true) s -> exists_ f s = true. + Parameter exists_2 : + compat_bool E.eq f -> + exists_ f s = true -> Exists (fun x => f x = true) s. + + (** Specification of [partition] *) + Parameter partition_1 : + compat_bool E.eq f -> Equal (fst (partition f s)) (filter f s). + Parameter partition_2 : + compat_bool E.eq f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + + (** 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. + + (** Specification of [choose] *) + Parameter choose_1 : choose s = Some x -> In x s. + Parameter choose_2 : choose s = None -> Empty s. + + End Filter. + End Spec. + + Hint Immediate In_1. + + Hint Resolve mem_1 mem_2 equal_1 equal_2 subset_1 subset_2 empty_1 + is_empty_1 is_empty_2 choose_1 choose_2 add_1 add_2 add_3 remove_1 + remove_2 remove_3 singleton_1 singleton_2 union_1 union_2 union_3 inter_1 + inter_2 inter_3 diff_1 diff_2 diff_3 filter_1 filter_2 filter_3 for_all_1 + for_all_2 exists_1 exists_2 partition_1 partition_2 elements_1 elements_2. + +End S. diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v new file mode 100644 index 00000000..74c81f37 --- /dev/null +++ b/theories/FSets/FSetWeakList.v @@ -0,0 +1,873 @@ +(***********************************************************************) +(* 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: FSetWeakList.v 8639 2006-03-16 19:21:55Z letouzey $ *) + +(** * Finite sets library *) + +(** This file proposes an implementation of the non-dependant + interface [FSetWeakInterface.S] using lists without redundancy. *) + +Require Import FSetWeakInterface. +Set Implicit Arguments. +Unset Strict Implicit. + +(** * Functions over lists + + First, we provide sets as lists which are (morally) without redundancy. + The specs are proved under the additional condition of no redundancy. + And the functions returning sets are proved to preserve this invariant. *) + +Module Raw (X: DecidableType). + + Module E := X. + + Definition elt := X.t. + Definition t := list elt. + + Definition empty : t := nil. + + Definition is_empty (l : t) : bool := if l then true else false. + + (** ** 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 : Set) (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. *) + + 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; do 2 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_3 : forall (s : t) (Hs : NoDup s), NoDup (elements s). + Proof. + unfold elements; auto. + Qed. + + Lemma fold_1 : + forall (s : t) (Hs : NoDup s) (A : Set) (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 : 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; firstorder. + Qed. + + Lemma eq_trans : forall s s' s'' : t, eq s s' -> eq s' s'' -> eq s s''. + Proof. + unfold eq, Equal; firstorder. + Qed. + +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. *) + +Module Make (X: DecidableType) <: S with Module E := X. + + Module E := X. + Module Raw := Raw X. + + Record slist : Set := {this :> Raw.t; unique : NoDupA X.eq this}. + Definition t := slist. + Definition elt := X.t. + + Definition In (x : elt) (s : t) := InA X.eq x s.(this). + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) (s : t) := + forall x : elt, In x s -> P x. + Definition Exists (P : elt -> Prop) (s : t) := exists x : elt, In x s /\ P x. + + Definition In_1 (s : t) := Raw.In_eq (s:=s). + + Definition mem (x : elt) (s : t) := Raw.mem x s. + Definition mem_1 (s : t) := Raw.mem_1 (s:=s). + Definition mem_2 (s : t) := Raw.mem_2 (s:=s). + + Definition add x s := Build_slist (Raw.add_unique (unique s) x). + Definition add_1 (s : t) := Raw.add_1 (unique s). + Definition add_2 (s : t) := Raw.add_2 (unique s). + Definition add_3 (s : t) := Raw.add_3 (unique s). + + Definition remove x s := Build_slist (Raw.remove_unique (unique s) x). + Definition remove_1 (s : t) := Raw.remove_1 (unique s). + Definition remove_2 (s : t) := Raw.remove_2 (unique s). + Definition remove_3 (s : t) := Raw.remove_3 (unique s). + + Definition singleton x := Build_slist (Raw.singleton_unique x). + Definition singleton_1 := Raw.singleton_1. + Definition singleton_2 := Raw.singleton_2. + + Definition union (s s' : t) := + Build_slist (Raw.union_unique (unique s) (unique s')). + Definition union_1 (s s' : t) := Raw.union_1 (unique s) (unique s'). + Definition union_2 (s s' : t) := Raw.union_2 (unique s) (unique s'). + Definition union_3 (s s' : t) := Raw.union_3 (unique s) (unique s'). + + Definition inter (s s' : t) := + Build_slist (Raw.inter_unique (unique s) (unique s')). + Definition inter_1 (s s' : t) := Raw.inter_1 (unique s) (unique s'). + Definition inter_2 (s s' : t) := Raw.inter_2 (unique s) (unique s'). + Definition inter_3 (s s' : t) := Raw.inter_3 (unique s) (unique s'). + + Definition diff (s s' : t) := + Build_slist (Raw.diff_unique (unique s) (unique s')). + Definition diff_1 (s s' : t) := Raw.diff_1 (unique s) (unique s'). + Definition diff_2 (s s' : t) := Raw.diff_2 (unique s) (unique s'). + Definition diff_3 (s s' : t) := Raw.diff_3 (unique s) (unique s'). + + Definition equal (s s' : t) := Raw.equal s s'. + Definition equal_1 (s s' : t) := Raw.equal_1 (unique s) (unique s'). + Definition equal_2 (s s' : t) := Raw.equal_2 (unique s) (unique s'). + + Definition subset (s s' : t) := Raw.subset s s'. + Definition subset_1 (s s' : t) := Raw.subset_1 (unique s) (unique s'). + Definition subset_2 (s s' : t) := Raw.subset_2 (unique s) (unique s'). + + Definition empty := Build_slist Raw.empty_unique. + Definition empty_1 := Raw.empty_1. + + Definition is_empty (s : t) := Raw.is_empty s. + Definition is_empty_1 (s : t) := Raw.is_empty_1 (s:=s). + Definition is_empty_2 (s : t) := Raw.is_empty_2 (s:=s). + + Definition elements (s : t) := Raw.elements s. + Definition elements_1 (s : t) := Raw.elements_1 (s:=s). + Definition elements_2 (s : t) := Raw.elements_2 (s:=s). + Definition elements_3 (s : t) := Raw.elements_3 (unique s). + + Definition choose (s:t) := Raw.choose s. + Definition choose_1 (s : t) := Raw.choose_1 (s:=s). + Definition choose_2 (s : t) := Raw.choose_2 (s:=s). + + Definition fold (B : Set) (f : elt -> B -> B) (s : t) := Raw.fold (B:=B) f s. + Definition fold_1 (s : t) := Raw.fold_1 (unique s). + + Definition cardinal (s : t) := Raw.cardinal s. + Definition cardinal_1 (s : t) := Raw.cardinal_1 (unique s). + + Definition filter (f : elt -> bool) (s : t) := + Build_slist (Raw.filter_unique (unique s) f). + Definition filter_1 (s : t)(x:elt)(f: elt -> bool)(H:compat_bool X.eq f) := + @Raw.filter_1 s x f. + Definition filter_2 (s : t) := Raw.filter_2 (s:=s). + Definition filter_3 (s : t) := Raw.filter_3 (s:=s). + + Definition for_all (f : elt -> bool) (s : t) := Raw.for_all f s. + Definition for_all_1 (s : t) := Raw.for_all_1 (s:=s). + Definition for_all_2 (s : t) := Raw.for_all_2 (s:=s). + + Definition exists_ (f : elt -> bool) (s : t) := Raw.exists_ f s. + Definition exists_1 (s : t) := Raw.exists_1 (s:=s). + Definition exists_2 (s : t) := Raw.exists_2 (s:=s). + + Definition partition (f : elt -> bool) (s : 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)). + Definition partition_1 (s : t) := Raw.partition_1 s. + Definition partition_2 (s : t) := Raw.partition_2 s. + + Definition eq (s s' : t) := Raw.eq s s'. + Definition eq_refl (s : t) := Raw.eq_refl s. + Definition eq_sym (s s' : t) := Raw.eq_sym (s:=s) (s':=s'). + Definition eq_trans (s s' s'' : t) := + Raw.eq_trans (s:=s) (s':=s') (s'':=s''). + +End Make. diff --git a/theories/FSets/FSets.v b/theories/FSets/FSets.v new file mode 100644 index 00000000..9dfcd51f --- /dev/null +++ b/theories/FSets/FSets.v @@ -0,0 +1,16 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* $Id: FSets.v 8667 2006-03-28 11:59:44Z letouzey $ *) + +Require Export OrderedType. +Require Export FSetInterface. +Require Export FSetBridge. +Require Export FSetProperties. +Require Export FSetEqProperties. +Require Export FSetList. diff --git a/theories/FSets/OrderedType.v b/theories/FSets/OrderedType.v new file mode 100644 index 00000000..2bf08dc7 --- /dev/null +++ b/theories/FSets/OrderedType.v @@ -0,0 +1,566 @@ +(***********************************************************************) +(* 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 8667 2006-03-28 11:59:44Z letouzey $ *) + +Require Export SetoidList. +Set Implicit Arguments. +Unset Strict Implicit. + +(* 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. +*) + +(** * Ordered types *) + +Inductive Compare (X : Set) (lt eq : X -> X -> Prop) (x y : X) : Set := + | 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 OrderedType. + + Parameter t : Set. + + Parameter eq : t -> t -> Prop. + Parameter 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 OrderedType. + +(** * Ordered types properties *) + +(** Additional properties that can be derived from signature + [OrderedType]. *) + +Module OrderedTypeFacts (O: OrderedType). + Import O. + + 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. + +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 : lt ?x ?y |- _ => revert H; abstraction + | H : ~lt ?x ?y |- _ => revert H; abstraction + | H : ~eq ?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 ]. + + Lemma eq_dec : forall x y : t, {eq x y} + {~ eq x y}. + Proof. + intros; elim (compare x y); [ right | left | right ]; auto. + Qed. + + Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. + Proof. + intros; elim (compare x y); [ left | right | right ]; auto. + Qed. + + 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. *) + +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. + +Hint Resolve ListIn_In Sort_NoDup Inf_lt. +Hint Immediate In_eq Inf_lt. + +End OrderedTypeFacts. + +Module PairOrderedType(O:OrderedType). + Import O. + Module MO:=OrderedTypeFacts(O). + Import MO. + + Section Elt. + Variable elt : Set. + 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 PairOrderedType. + + |