diff options
27 files changed, 10443 insertions, 13 deletions
diff --git a/Makefile.common b/Makefile.common index 918d637e1b..67abba61b9 100644 --- a/Makefile.common +++ b/Makefile.common @@ -308,10 +308,16 @@ LOGICVO:=$(addprefix theories/Logic/, \ Decidable.vo JMeq.vo ClassicalChoice.vo \ ClassicalDescription.vo RelationalChoice.vo Diaconescu.vo \ EqdepFacts.vo ProofIrrelevanceFacts.vo ClassicalEpsilon.vo \ - ClassicalUniqueChoice.vo DecidableType.vo DecidableTypeEx.vo \ + ClassicalUniqueChoice.vo \ Epsilon.vo ConstructiveEpsilon.vo Description.vo \ IndefiniteDescription.vo SetIsType.vo FunctionalExtensionality.vo ) +STRUCTURESVO:=$(addprefix theories/Structures/, \ + DecidableType.vo DecidableTypeEx.vo \ + OrderedType.vo OrderedTypeEx.vo OrderedTypeAlt.vo \ + DecidableType2.vo DecidableType2Ex.vo \ + OrderedType2.vo OrderedType2Ex.vo OrderedType2Alt.vo ) + ARITHVO:=$(addprefix theories/Arith/, \ Arith.vo Gt.vo Between.vo Le.vo \ Compare.vo Lt.vo Compare_dec.vo Min.vo \ @@ -349,7 +355,8 @@ QARITHVO:=$(addprefix theories/QArith/, \ LISTSVO:=$(addprefix theories/Lists/, \ ListSet.vo Streams.vo StreamMemo.vo \ - TheoryList.vo List.vo SetoidList.vo ListTactics.vo ) + TheoryList.vo List.vo SetoidList.vo SetoidList2.vo \ + ListTactics.vo ) STRINGSVO:=$(addprefix theories/Strings/, \ Ascii.vo String.vo ) @@ -368,7 +375,6 @@ SETSVO:=$(addprefix theories/Sets/, \ Partial_Order.vo Uniset.vo ) FSETSBASEVO:=$(addprefix theories/FSets/, \ - OrderedType.vo OrderedTypeEx.vo OrderedTypeAlt.vo \ FSetInterface.vo FSetList.vo FSetBridge.vo \ FSetFacts.vo FSetProperties.vo FSetEqProperties.vo \ FSetWeakList.vo FSetAVL.vo FSetDecide.vo \ @@ -386,6 +392,12 @@ FSETSVO:=$(FSETSBASEVO) $(FSETS_$(FSETS)) ALLFSETS:=$(FSETSBASEVO) $(FSETS_all) +MSETSVO:=$(addprefix theories/MSets/, \ + MSetInterface.vo MSetList.vo \ + MSetFacts.vo MSetProperties.vo MSetEqProperties.vo \ + MSetWeakList.vo MSetAVL.vo MSetDecide.vo \ + MSets.vo ) + RELATIONSVO:=$(addprefix theories/Relations/, \ Operators_Properties.vo Relation_Definitions.vo \ Relation_Operators.vo Relations.vo ) @@ -511,9 +523,9 @@ PROGRAMVO:=$(addprefix theories/Program/, \ THEORIESVO:=\ $(INITVO) $(LOGICVO) $(ARITHVO) $(BOOLVO) $(NARITHVO) $(ZARITHVO) \ - $(SETOIDSVO) $(LISTSVO) $(STRINGSVO) $(SETSVO) $(FSETSVO) \ + $(SETOIDSVO) $(LISTSVO) $(STRINGSVO) $(SETSVO) $(FSETSVO) $(MSETSVO) \ $(RELATIONSVO) $(WELLFOUNDEDVO) $(REALSVO) $(SORTINGVO) $(QARITHVO) \ - $(NUMBERSVO) $(UNICODEVO) $(CLASSESVO) $(PROGRAMVO) + $(NUMBERSVO) $(UNICODEVO) $(CLASSESVO) $(PROGRAMVO) $(STRUCTURESVO) THEORIESLIGHTVO:= $(INITVO) $(LOGICVO) $(ARITHVO) diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index fe2f553113..a0ce827a91 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -279,7 +279,7 @@ Program Instance compose_proper A B C R₀ R₁ R₂ : unfold compose. apply H. apply H0. apply H1. Qed. -(** Coq functions are morphisms for leibniz equality, +(** Coq functions are morphisms for Leibniz equality, applied only if really needed. *) Instance reflexive_eq_dom_reflexive (A : Type) `(Reflexive B R') : @@ -488,3 +488,98 @@ Ltac proper_reflexive := end. Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances. + + +(** When the relation on the domain is symmetric, we can + inverse the relation on the codomain. Same for binary functions. *) + +Lemma proper_sym_flip + `(Symmetric A R1)`(Proper (A->B) (R1==>R2) f) : + Proper (R1==>inverse R2) f. +Proof. +intros A R1 Sym B R2 f Hf. +intros x x' Hxx'. apply Hf, Sym, Hxx'. +Qed. + +Lemma proper_sym_flip_2 + `(Symmetric A R1)`(Symmetric B R2)`(Proper (A->B->C) (R1==>R2==>R3) f) : + Proper (R1==>R2==>inverse R3) f. +Proof. +intros A R1 Sym1 B R2 Sym2 C R3 f Hf. +intros x x' Hxx' y y' Hyy'. apply Hf; auto. +Qed. + +(** When the relation on the domain is symmetric, a predicate is + compatible with [iff] as soon as it is compatible with [impl]. + Same with a binary relation. *) + +Lemma proper_sym_impl_iff `(Symmetric A R)`(Proper _ (R==>impl) f) : + Proper (R==>iff) f. +Proof. +intros A R Sym f Hf x x' Hxx'. repeat red in Hf. split; eauto. +Qed. + +Lemma proper_sym_impl_iff_2 + `(Symmetric A R)`(Symmetric B R')`(Proper _ (R==>R'==>impl) f) : + Proper (R==>R'==>iff) f. +Proof. +intros A R Sym B R' Sym' f Hf x x' Hxx' y y' Hyy'. +repeat red in Hf. split; eauto. +Qed. + +(** A [PartialOrder] is compatible with its underlying equivalence. *) + +Instance PartialOrder_proper `(PartialOrder A eqA R) : + Proper (eqA==>eqA==>iff) R. +Proof. +intros. +apply proper_sym_impl_iff_2; auto with *. +intros x x' Hx y y' Hy Hr. +transitivity x. +generalize (partial_order_equivalence x x'); compute; intuition. +transitivity y; auto. +generalize (partial_order_equivalence y y'); compute; intuition. +Qed. + +(** From a [PartialOrder] to the corresponding [StrictOrder]: + [lt = le /\ ~eq]. + If the order is total, we could also say [gt = ~le]. *) + +Instance PartialOrder_StrictOrder `(PartialOrder A eqA R) : + StrictOrder (relation_conjunction R (complement eqA)). +Proof. +split; compute. +intros x (_,Hx). apply Hx, Equivalence_Reflexive. +intros x y z (Hxy,Hxy') (Hyz,Hyz'). split. +apply PreOrder_Transitive with y; assumption. +intro Hxz. +apply Hxy'. +apply partial_order_antisym; auto. +rewrite Hxz; auto. +Qed. + +(** From a [StrictOrder] to the corresponding [PartialOrder]: + [le = lt \/ eq]. + If the order is total, we could also say [ge = ~lt]. *) + +Instance StrictOrder_PreOrder + `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iff) R) : + PreOrder (relation_disjunction R eqA). +Proof. +split. +intros x. right. reflexivity. +intros x y z [Hxy|Hxy] [Hyz|Hyz]. +left. transitivity y; auto. +left. rewrite <- Hyz; auto. +left. rewrite Hxy; auto. +right. transitivity y; auto. +Qed. + +Instance StrictOrder_PartialOrder + `(Equivalence A eqA, StrictOrder A R, Proper _ (eqA==>eqA==>iff) R) : + PartialOrder eqA (relation_disjunction R eqA). +Proof. +intros. intros x y. compute. intuition. +elim (StrictOrder_Irreflexive x). +transitivity y; auto. +Qed. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index bc25fe488d..83095720a4 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -47,7 +47,7 @@ Class Reflexive {A} (R : relation A) := Class Irreflexive {A} (R : relation A) := irreflexivity : Reflexive (complement R). -Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclasses_instances. +Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. Class Symmetric {A} (R : relation A) := symmetry : forall x y, R x y -> R y x. @@ -417,3 +417,30 @@ Instance: RewriteRelation (@relation_equivalence A). a rewrite relation. *) Instance equivalence_rewrite_relation `(Equivalence A eqA) : RewriteRelation eqA. + +(** Strict Order *) + +Class StrictOrder {A : Type} (R : relation A) := { + StrictOrder_Irreflexive :> Irreflexive R ; + StrictOrder_Transitive :> Transitive R +}. + +Instance StrictOrder_Asymmetric `(StrictOrder A R) : Asymmetric R. +Proof. + firstorder. +Qed. + +(** Inversing a [StrictOrder] gives another [StrictOrder] *) + +Instance StrictOrder_inverse `(StrictOrder A R) : StrictOrder (inverse R). + +(** Same for [PartialOrder]. *) + +Instance PreOrder_inverse `(PreOrder A R) : PreOrder (inverse R). + +Instance PartialOrder_inverse `(PartialOrder A eqA R) : + PartialOrder eqA (inverse R). +Proof. +firstorder. +Qed. + diff --git a/theories/Lists/List.v b/theories/Lists/List.v index f2961635ec..228661ec64 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -1874,8 +1874,65 @@ Section NatSeq. End NatSeq. +(** * Existential and universal predicates over lists *) - (** * Exporting hints and tactics *) +Inductive ExistsL {A} (P:A->Prop) : list A -> Prop := + | ExistsL_cons_hd : forall x l, P x -> ExistsL P (x::l) + | ExistsL_cons_tl : forall x l, ExistsL P l -> ExistsL P (x::l). +Hint Constructors ExistsL. + +Lemma ExistsL_exists : forall A P (l:list A), + ExistsL P l <-> (exists x, In x l /\ P x). +Proof. +split. +induction 1; firstorder. +induction l; firstorder; subst; auto. +Qed. + +Lemma ExistsL_nil : forall A (P:A->Prop), ExistsL P nil <-> False. +Proof. split; inversion 1. Qed. + +Lemma ExistsL_cons : forall A (P:A->Prop) x l, + ExistsL P (x::l) <-> P x \/ ExistsL P l. +Proof. split; inversion 1; auto. Qed. + + +Inductive ForallL {A} (P:A->Prop) : list A -> Prop := + | ForallL_nil : ForallL P nil + | ForallL_cons : forall x l, P x -> ForallL P l -> ForallL P (x::l). +Hint Constructors ForallL. + +Lemma ForallL_forall : forall A P (l:list A), + ForallL P l <-> (forall x, In x l -> P x). +Proof. +split. +induction 1; firstorder; subst; auto. +induction l; firstorder. +Qed. + + +(** * Inversion of predicates over lists based on head symbol *) + +Ltac is_list_constr c := + match c with + | nil => idtac + | (_::_) => idtac + | _ => fail + end. + +Ltac invlist f := + match goal with + | H:f ?l |- _ => is_list_constr l; inversion_clear H; invlist f + | H:f _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f + | H:f _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f + | H:f _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f + | H:f _ _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f + | _ => idtac + end. + + + +(** * Exporting hints and tactics *) Hint Rewrite diff --git a/theories/Lists/SetoidList2.v b/theories/Lists/SetoidList2.v new file mode 100644 index 0000000000..78226cb5d1 --- /dev/null +++ b/theories/Lists/SetoidList2.v @@ -0,0 +1,850 @@ +(***********************************************************************) +(* 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$ *) + +Require Export List. +Require Export Sorting. +Require Export Setoid Basics Morphisms. +Set Implicit Arguments. +Unset Strict Implicit. + +(** * Logical relations over lists with respect to a setoid equality + or ordering. *) + +(** This can be seen as a complement of predicate [lelistA] and [sort] + found in [Sorting]. *) + +Section Type_with_equality. +Variable A : Type. +Variable eqA : A -> A -> Prop. + +(** Being in a list modulo an equality relation over type [A]. *) + +Inductive InA (x : A) : list A -> Prop := + | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l) + | InA_cons_tl : forall y l, InA x l -> InA x (y :: l). + +Hint Constructors InA. + +(** TODO: it would be nice to have a generic definition instead + of the previous one. Having [InA = ExistsL eqA] raises too + many compatibility issues. For now, we only state the equivalence: *) + +Lemma InA_altdef : forall x l, InA x l <-> ExistsL (eqA x) l. +Proof. split; induction 1; auto. Qed. + +Lemma InA_cons : forall x y l, InA x (y::l) <-> eqA x y \/ InA x l. +Proof. + intuition. invlist InA; auto. +Qed. + +Lemma InA_nil : forall x, InA x nil <-> False. +Proof. + intuition. invlist InA. +Qed. + +(** An alternative definition of [InA]. *) + +Lemma InA_alt : forall x l, InA x l <-> exists y, eqA x y /\ In y l. +Proof. + intros; rewrite InA_altdef, ExistsL_exists; firstorder. +Qed. + +(** A list without redundancy modulo the equality over [A]. *) + +Inductive NoDupA : list A -> Prop := + | NoDupA_nil : NoDupA nil + | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l). + +Hint Constructors NoDupA. + + +Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA. + +(** lists with same elements modulo [eqA] *) + +Definition equivlistA l l' := forall x, InA x l <-> InA x l'. + +(** lists with same elements modulo [eqA] at the same place *) + +Inductive eqlistA : list A -> list A -> Prop := + | eqlistA_nil : eqlistA nil nil + | eqlistA_cons : forall x x' l l', + eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). + +Hint Constructors eqlistA. + +(** Results concerning lists modulo [eqA] *) + +Hypothesis eqA_equiv : Equivalence eqA. + +Hint Resolve (@Equivalence_Reflexive _ _ eqA_equiv). +Hint Resolve (@Equivalence_Transitive _ _ eqA_equiv). +Hint Immediate (@Equivalence_Symmetric _ _ eqA_equiv). + +(** First, the two notions [equivlistA] and [eqlistA] are indeed equivlances *) + +Global Instance equivlist_equiv : Equivalence equivlistA. +Proof. + firstorder. +Qed. + +Global Instance eqlistA_equiv : Equivalence eqlistA. +Proof. + constructor; red. + induction x; auto. + induction 1; auto. + intros x y z H; revert z; induction H; auto. + inversion 1; subst; auto. invlist eqlistA; eauto with *. +Qed. + +(** Moreover, [eqlistA] implies [equivlistA]. A reverse result + will be proved later for sorted list without duplicates. *) + +Global Instance eqlistA_equivlistA : subrelation eqlistA equivlistA. +Proof. + intros x x' H. induction H. + intuition. + red; intros. + rewrite 2 InA_cons. + rewrite (IHeqlistA x0), H; intuition. +Qed. + +(** InA is compatible with eqA (for its first arg) and with + equivlistA (and hence eqlistA) for its second arg *) + +Global Instance InA_compat : Proper (eqA==>equivlistA==>iff) InA. +Proof. + intros x x' Hxx' l l' Hll'. rewrite (Hll' x). + rewrite 2 InA_alt; firstorder. +Qed. + +(** For compatibility, an immediate consequence of [InA_compat] *) + +Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. +Proof. + intros l x y H H'. rewrite <- H; auto. +Qed. +Hint Immediate InA_eqA. + +Lemma In_InA : forall l x, In x l -> InA x l. +Proof. + simple induction l; simpl; intuition. + subst; auto. +Qed. +Hint Resolve In_InA. + +Lemma InA_split : forall l x, InA x l -> + exists l1, exists y, exists l2, + eqA x y /\ l = l1++y::l2. +Proof. +induction l; intros; inv. +exists (@nil A); exists a; exists l; auto. +destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))). +exists (a::l1); exists y; exists l2; auto. +split; simpl; f_equal; auto. +Qed. + +Lemma InA_app : forall l1 l2 x, + InA x (l1 ++ l2) -> InA x l1 \/ InA x l2. +Proof. + induction l1; simpl in *; intuition. + inv; auto. + elim (IHl1 l2 x H0); auto. +Qed. + +Lemma InA_app_iff : forall l1 l2 x, + InA x (l1 ++ l2) <-> InA x l1 \/ InA x l2. +Proof. + split. + apply InA_app. + destruct 1; generalize H; do 2 rewrite InA_alt. + destruct 1 as (y,(H1,H2)); exists y; split; auto. + apply in_or_app; auto. + destruct 1 as (y,(H1,H2)); exists y; split; auto. + apply in_or_app; auto. +Qed. + +Lemma InA_rev : forall p m, + InA p (rev m) <-> InA p m. +Proof. + intros; do 2 rewrite InA_alt. + split; intros (y,H); exists y; intuition. + rewrite In_rev; auto. + rewrite <- In_rev; auto. +Qed. + + + +Section NoDupA. + +Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> + (forall x, InA x l -> InA x l' -> False) -> + NoDupA (l++l'). +Proof. +induction l; simpl; auto; intros. +inv. +constructor. +rewrite InA_alt; intros (y,(H4,H5)). +destruct (in_app_or _ _ _ H5). +elim H2. +rewrite InA_alt. +exists y; auto. +apply (H1 a). +auto. +rewrite InA_alt. +exists y; auto. +apply IHl; auto. +intros. +apply (H1 x); auto. +Qed. + +Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l). +Proof. +induction l. +simpl; auto. +simpl; intros. +inv. +apply NoDupA_app; auto. +constructor; auto. +intro; inv. +intros x. +rewrite InA_alt. +intros (x1,(H2,H3)). +intro; inv. +destruct H0. +rewrite <- H4, H2. +apply In_InA. +rewrite In_rev; auto. +Qed. + +Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l'). +Proof. + induction l; simpl in *; intros; inv; auto. + constructor; eauto. + contradict H0. + rewrite InA_app_iff in *. + rewrite InA_cons. + intuition. +Qed. + +Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l'). +Proof. + induction l; simpl in *; intros; inv; auto. + constructor; eauto. + assert (H2:=IHl _ _ H1). + inv. + rewrite InA_cons. + red; destruct 1. + apply H0. + rewrite InA_app_iff in *; rewrite InA_cons; auto. + apply H; auto. + constructor. + contradict H0. + rewrite InA_app_iff in *; rewrite InA_cons; intuition. + eapply NoDupA_split; eauto. +Qed. + +Lemma equivlistA_NoDupA_split : forall l l1 l2 x y, eqA x y -> + NoDupA (x::l) -> NoDupA (l1++y::l2) -> + equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2). +Proof. + intros; intro a. + generalize (H2 a). + rewrite !InA_app_iff, !InA_cons. + inv. + assert (SW:=NoDupA_swap H1). inv. + rewrite InA_app_iff in H0. + split; intros. + assert (~eqA a x) by (contradict H3; rewrite <- H3; auto). + assert (~eqA a y) by (rewrite <- H; auto). + tauto. + assert (OR : eqA a x \/ InA a l) by intuition. clear H6. + destruct OR as [EQN|INA]; auto. + elim H0. + rewrite <-H,<-EQN; auto. +Qed. + +End NoDupA. + + + +Section Fold. + +Variable B:Type. +Variable eqB:B->B->Prop. +Variable st:Equivalence eqB. +Variable f:A->B->B. +Variable i:B. +Variable Comp:Proper (eqA==>eqB==>eqB) f. + +Lemma fold_right_eqlistA : + forall s s', eqlistA s s' -> + eqB (fold_right f i s) (fold_right f i s'). +Proof. +induction 1; simpl; auto with relations. +apply Comp; auto. +Qed. + +(** [ForallL2] : specifies that a certain binary predicate should + always hold when inspecting two different elements of the list. *) + +Inductive ForallL2 (R : A -> A -> Prop) : list A -> Prop := + | ForallNil : ForallL2 R nil + | ForallCons : forall a l, + (forall b, In b l -> R a b) -> + ForallL2 R l -> ForallL2 R (a::l). +Hint Constructors ForallL2. + +(** [NoDupA] can be written in terms of [ForallL2] *) + +Lemma ForallL2_NoDupA : forall l, + ForallL2 (fun a b => ~eqA a b) l <-> NoDupA l. +Proof. + induction l; split; intros; auto. + invlist ForallL2. constructor; [ | rewrite <- IHl; auto ]. + rewrite InA_alt; intros (a',(Haa',Ha')). + exact (H0 a' Ha' Haa'). + invlist NoDupA. constructor; [ | rewrite IHl; auto ]. + intros b Hb. + contradict H0. + rewrite InA_alt; exists b; auto. +Qed. + +Lemma ForallL2_impl : forall (R R':A->A->Prop), + (forall a b, R a b -> R' a b) -> + forall l, ForallL2 R l -> ForallL2 R' l. +Proof. + induction 2; auto. +Qed. + +(** The following definition is easier to use than [ForallL2]. *) + +Definition ForallL2_alt (R:A->A->Prop) l := + forall a b, InA a l -> InA b l -> ~eqA a b -> R a b. + +Section Restriction. +Variable R : A -> A -> Prop. + +(** [ForallL2] and [ForallL2_alt] are related, but no completely + equivalent. For proving one implication, we need to know that the + list has no duplicated elements... *) + +Lemma ForallL2_equiv1 : forall l, NoDupA l -> + ForallL2_alt R l -> ForallL2 R l. +Proof. + induction l; auto. + constructor. intros b Hb. + inv. + apply H0; auto. + contradict H1; rewrite H1; auto. + apply IHl. + inv; auto. + intros b c Hb Hc Hneq. + apply H0; auto. +Qed. + +(** ... and for proving the other implication, we need to be able + to reverse and adapt relation [R] modulo [eqA]. *) + +Hypothesis R_sym : Symmetric R. +Hypothesis R_compat : Proper (eqA==>eqA==>iff) R. + +Lemma ForallL2_equiv2 : forall l, + ForallL2 R l -> ForallL2_alt R l. +Proof. + induction l. + intros _. red. intros a b Ha. inv. + inversion_clear 1 as [|? ? H_R Hl]. + intros b c Hb Hc Hneq. + inv. + (* b,c = a : impossible *) + elim Hneq; eauto. + (* b = a, c in l *) + rewrite InA_alt in H0; destruct H0 as (d,(Hcd,Hd)). + rewrite H, Hcd; auto. + (* b in l, c = a *) + rewrite InA_alt in H; destruct H as (d,(Hcd,Hd)). + rewrite H0, Hcd; auto. + (* b,c in l *) + apply (IHl Hl); auto. +Qed. + +Lemma ForallL2_equiv : forall l, NoDupA l -> + (ForallL2 R l <-> ForallL2_alt R l). +Proof. +split; [apply ForallL2_equiv2|apply ForallL2_equiv1]; auto. +Qed. + +Lemma ForallL2_equivlistA : forall l l', NoDupA l' -> + equivlistA l l' -> ForallL2 R l -> ForallL2 R l'. +Proof. +intros. +apply ForallL2_equiv1; auto. +intros a b Ha Hb Hneq. +red in H0; rewrite <- H0 in Ha,Hb. +revert a b Ha Hb Hneq. +change (ForallL2_alt R l). +apply ForallL2_equiv2; auto. +Qed. + +(** Two-argument functions that allow to reorder their arguments. *) +Definition transpose (f : A -> B -> B) := + forall (x y : A) (z : B), eqB (f x (f y z)) (f y (f x z)). + +(** A version of transpose with restriction on where it should hold *) +Definition transpose_restr (R : A -> A -> Prop)(f : A -> B -> B) := + forall (x y : A) (z : B), R x y -> eqB (f x (f y z)) (f y (f x z)). + +Variable TraR :transpose_restr R f. + +Lemma fold_right_commutes_restr : + forall s1 s2 x, ForallL2 R (s1++x::s2) -> + eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). +Proof. +induction s1; simpl; auto; intros. +reflexivity. +transitivity (f a (f x (fold_right f i (s1++s2)))). +apply Comp; auto. +apply IHs1. +invlist ForallL2; auto. +apply TraR. +invlist ForallL2; auto. +apply H0. +apply in_or_app; simpl; auto. +Qed. + +Lemma fold_right_equivlistA_restr : + forall s s', NoDupA s -> NoDupA s' -> ForallL2 R s -> + equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). +Proof. + simple induction s. + destruct s'; simpl. + intros; reflexivity. + unfold equivlistA; intros. + destruct (H2 a). + assert (InA a nil) by auto; inv. + intros x l Hrec s' N N' F E; simpl in *. + assert (InA x s') by (rewrite <- (E x); auto). + destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). + subst s'. + transitivity (f x (fold_right f i (s1++s2))). + apply Comp; auto. + apply Hrec; auto. + inv; auto. + eapply NoDupA_split; eauto. + invlist ForallL2; auto. + eapply equivlistA_NoDupA_split; eauto. + transitivity (f y (fold_right f i (s1++s2))). + apply Comp; auto. reflexivity. + symmetry; apply fold_right_commutes_restr. + apply ForallL2_equivlistA with (x::l); auto. +Qed. + +Lemma fold_right_add_restr : + forall s' s x, NoDupA s -> NoDupA s' -> ForallL2 R s' -> ~ InA x s -> + equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). +Proof. + intros; apply (@fold_right_equivlistA_restr s' (x::s)); auto. +Qed. + +End Restriction. + +(** we now state similar results, but without restriction on transpose. *) + +Variable Tra :transpose f. + +Lemma fold_right_commutes : forall s1 s2 x, + eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). +Proof. +induction s1; simpl; auto; intros. +reflexivity. +transitivity (f a (f x (fold_right f i (s1++s2)))); auto. +apply Comp; auto. +Qed. + +Lemma fold_right_equivlistA : + forall s s', NoDupA s -> NoDupA s' -> + equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). +Proof. +intros; apply fold_right_equivlistA_restr with (R:=fun _ _ => True); + repeat red; auto. +apply ForallL2_equiv1; try red; auto. +Qed. + +Lemma fold_right_add : + forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s -> + equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). +Proof. + intros; apply (@fold_right_equivlistA s' (x::s)); auto. +Qed. + +End Fold. + +Section Remove. + +Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. + +Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }. +Proof. +induction l. +right; auto. +intro; inv. +destruct (eqA_dec x a). +left; auto. +destruct IHl. +left; auto. +right; intro; inv; contradiction. +Qed. + +Fixpoint removeA (x : A) (l : list A) : list A := + match l with + | nil => nil + | y::tl => if (eqA_dec x y) then removeA x tl else y::(removeA x tl) + end. + +Lemma removeA_filter : forall x l, + removeA x l = filter (fun y => if eqA_dec x y then false else true) l. +Proof. +induction l; simpl; auto. +destruct (eqA_dec x a); auto. +rewrite IHl; auto. +Qed. + +Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y. +Proof. +induction l; simpl; auto. +split. +intro; inv. +destruct 1; inv. +intros. +destruct (eqA_dec x a); simpl; auto. +rewrite IHl; split; destruct 1; split; auto. +inv; auto. +destruct H0; transitivity a; auto. +split. +intro; inv. +split; auto. +contradict n. +transitivity y; auto. +rewrite (IHl x y) in H0; destruct H0; auto. +destruct 1; inv; auto. +right; rewrite IHl; auto. +Qed. + +Lemma removeA_NoDupA : + forall s x, NoDupA s -> NoDupA (removeA x s). +Proof. +simple induction s; simpl; intros. +auto. +inv. +destruct (eqA_dec x a); simpl; auto. +constructor; auto. +rewrite removeA_InA. +intuition. +Qed. + +Lemma removeA_equivlistA : forall l l' x, + ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l'). +Proof. +unfold equivlistA; intros. +rewrite removeA_InA. +split; intros. +rewrite <- H0; split; auto. +contradict H. +apply InA_eqA with x0; auto. +rewrite <- (H0 x0) in H1. +destruct H1. +inv; auto. +elim H2; auto. +Qed. + +End Remove. + + + +(** Results concerning lists modulo [eqA] and [ltA] *) + +Variable ltA : A -> A -> Prop. +Hypothesis ltA_strorder : StrictOrder ltA. +Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA. + +Hint Resolve (@StrictOrder_Transitive _ _ ltA_strorder). + +Notation InfA:=(lelistA ltA). +Notation SortA:=(sort ltA). + +Hint Constructors lelistA sort. + +Lemma InfA_ltA : + forall l x y, ltA x y -> InfA y l -> InfA x l. +Proof. + destruct l; constructor. inv; eauto. +Qed. + +Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA. +Proof. + intros x x' Hxx' l l' Hll'. + inversion_clear Hll'. + intuition. + split; intro; inv; constructor. + rewrite <- Hxx', <- H; auto. + rewrite Hxx', H; auto. +Qed. + +(** For compatibility, can be deduced from [InfA_compat] *) +Lemma InfA_eqA : + forall l x y, eqA x y -> InfA y l -> InfA x l. +Proof. + intros l x y H; rewrite H; auto. +Qed. +Hint Immediate InfA_ltA InfA_eqA. + +Lemma SortA_InfA_InA : + forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. +Proof. + simple induction l. + intros. inv. + intros. inv. + setoid_replace x with a; auto. + eauto. +Qed. + +Lemma In_InfA : + forall l x, (forall y, In y l -> ltA x y) -> InfA x l. +Proof. + simple induction l; simpl; intros; constructor; auto. +Qed. + +Lemma InA_InfA : + forall l x, (forall y, InA y l -> ltA x y) -> InfA x l. +Proof. + simple induction l; simpl; intros; constructor; auto. +Qed. + +(* In fact, this may be used as an alternative definition for InfA: *) + +Lemma InfA_alt : + forall l x, SortA l -> (InfA x l <-> (forall y, InA y l -> ltA x y)). +Proof. +split. +intros; eapply SortA_InfA_InA; eauto. +apply InA_InfA. +Qed. + +Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2). +Proof. + induction l1; simpl; auto. + intros; inv; auto. +Qed. + +Lemma SortA_app : + forall l1 l2, SortA l1 -> SortA l2 -> + (forall x y, InA x l1 -> InA y l2 -> ltA x y) -> + SortA (l1 ++ l2). +Proof. + induction l1; simpl in *; intuition. + inv. + constructor; auto. + apply InfA_app; auto. + destruct l2; auto. +Qed. + +Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l. +Proof. + simple induction l; auto. + intros x l' H H0. + inv. + constructor; auto. + intro. + apply (StrictOrder_Irreflexive x). + eapply SortA_InfA_InA; eauto. +Qed. + + +(** Some results about [eqlistA] *) + +Section EqlistA. + +Lemma eqlistA_length : forall l l', eqlistA l l' -> length l = length l'. +Proof. +induction 1; auto; simpl; congruence. +Qed. + +Global Instance app_eqlistA_compat : + Proper (eqlistA==>eqlistA==>eqlistA) (@app A). +Proof. + repeat red; induction 1; simpl; auto. +Qed. + +(** For compatibility, can be deduced from app_eqlistA_compat **) +Lemma eqlistA_app : forall l1 l1' l2 l2', + eqlistA l1 l1' -> eqlistA l2 l2' -> eqlistA (l1++l2) (l1'++l2'). +Proof. +intros l1 l1' l2 l2' H H'; rewrite H, H'; reflexivity. +Qed. + +Lemma eqlistA_rev_app : forall l1 l1', + eqlistA l1 l1' -> forall l2 l2', eqlistA l2 l2' -> + eqlistA ((rev l1)++l2) ((rev l1')++l2'). +Proof. +induction 1; auto. +simpl; intros. +do 2 rewrite app_ass; simpl; auto. +Qed. + +Global Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A). +Proof. +repeat red. intros. +rewrite (app_nil_end (rev x)), (app_nil_end (rev y)). +apply eqlistA_rev_app; auto. +Qed. + +Lemma eqlistA_rev : forall l1 l1', + eqlistA l1 l1' -> eqlistA (rev l1) (rev l1'). +Proof. +apply rev_eqlistA_compat. +Qed. + +Lemma SortA_equivlistA_eqlistA : forall l l', + SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'. +Proof. +induction l; destruct l'; simpl; intros; auto. +destruct (H1 a); assert (InA a nil) by auto; inv. +destruct (H1 a); assert (InA a nil) by auto; inv. +inv. +assert (forall y, InA y l -> ltA a y). +intros; eapply SortA_InfA_InA with (l:=l); eauto. +assert (forall y, InA y l' -> ltA a0 y). +intros; eapply SortA_InfA_InA with (l:=l'); eauto. +clear H3 H4. +assert (eqA a a0). + destruct (H1 a). + destruct (H1 a0). + assert (InA a (a0::l')) by auto. inv; auto. + assert (InA a0 (a::l)) by auto. inv; auto. + elim (StrictOrder_Irreflexive a); eauto. +constructor; auto. +apply IHl; auto. +split; intros. +destruct (H1 x). +assert (InA x (a0::l')) by auto. inv; auto. +rewrite H9,<-H3 in H4. elim (StrictOrder_Irreflexive a); eauto. +destruct (H1 x). +assert (InA x (a::l)) by auto. inv; auto. +rewrite H9,H3 in H4. elim (StrictOrder_Irreflexive a0); eauto. +Qed. + +End EqlistA. + +(** A few things about [filter] *) + +Section Filter. + +Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l). +Proof. +induction l; simpl; auto. +intros; inv; auto. +destruct (f a); auto. +constructor; auto. +apply In_InfA; auto. +intros. +rewrite filter_In in H; destruct H. +eapply SortA_InfA_InA; eauto. +Qed. + +Implicit Arguments eq [ [A] ]. + +Lemma filter_InA : forall f, Proper (eqA==>eq) f -> + forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true. +Proof. +clear ltA ltA_compat ltA_strorder. +intros; do 2 rewrite InA_alt; intuition. +destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition. +destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition. + rewrite (H _ _ H0); auto. +destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition. + rewrite <- (H _ _ H0); auto. +Qed. + +Lemma filter_split : + forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> + forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l. +Proof. +induction l; simpl; intros; auto. +inv. +rewrite IHl at 1; auto. +case_eq (f a); simpl; intros; auto. +assert (forall e, In e l -> f e = false). + intros. + assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)). + case_eq (f e); simpl; intros; auto. + elim (StrictOrder_Irreflexive e). + transitivity a; auto. +replace (List.filter f l) with (@nil A); auto. +generalize H3; clear; induction l; simpl; auto. +case_eq (f a); auto; intros. +rewrite H3 in H; auto; try discriminate. +Qed. + +End Filter. +End Type_with_equality. + + +Hint Constructors InA eqlistA NoDupA sort lelistA. + +Section Find. + +Variable A B : Type. +Variable eqA : A -> A -> Prop. +Hypothesis eqA_equiv : Equivalence eqA. +Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. + +Fixpoint findA (f : A -> bool) (l:list (A*B)) : option B := + match l with + | nil => None + | (a,b)::l => if f a then Some b else findA f l + end. + +Lemma findA_NoDupA : + forall l a b, + NoDupA (fun p p' => eqA (fst p) (fst p')) l -> + (InA (fun p p' => eqA (fst p) (fst p') /\ snd p = snd p') (a,b) l <-> + findA (fun a' => if eqA_dec a a' then true else false) l = Some b). +Proof. +set (eqk := fun p p' : A*B => eqA (fst p) (fst p')). +set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p'). +induction l; intros; simpl. +split; intros; try discriminate. +invlist InA. +destruct a as (a',b'); rename a0 into a. +invlist NoDupA. +split; intros. +invlist InA. +compute in H2; destruct H2. subst b'. +destruct (eqA_dec a a'); intuition. +destruct (eqA_dec a a'); simpl. +contradict H0. +revert e H2; clear - eqA_equiv. +induction l. +intros; invlist InA. +intros; invlist InA; auto. +destruct a0. +compute in H; destruct H. +subst b. +left; auto. +compute. +transitivity a; auto. symmetry; auto. +rewrite <- IHl; auto. +destruct (eqA_dec a a'); simpl in *. +left; split; simpl; congruence. +right. rewrite IHl; auto. +Qed. + +End Find. diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v new file mode 100644 index 0000000000..e38bf171ef --- /dev/null +++ b/theories/MSets/MSetAVL.v @@ -0,0 +1,1851 @@ +(* -*- coding: utf-8 -*- *) +(***********************************************************************) +(* 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$ *) + +(** * MSetAVL : Implementation of MSetInterface via AVL trees *) + +(** This module implements finite sets using AVL trees. + It follows the implementation from Ocaml's standard library, + + All operations given here expect and produce well-balanced trees + (in the ocaml sense: heigths of subtrees shouldn't differ by more + than 2), and hence has low complexities (e.g. add is logarithmic + in the size of the set). But proving these balancing preservations + is in fact not necessary for ensuring correct operational behavior + and hence fulfilling the MSet interface. As a consequence, + balancing results are not part of this file anymore, they can + now be found in [MSetFullAVL]. + + Four operations ([union], [subset], [compare] and [equal]) have + been slightly adapted in order to have only structural recursive + calls. The precise ocaml versions of these operations have also + been formalized (thanks to Function+measure), see [ocaml_union], + [ocaml_subset], [ocaml_compare] and [ocaml_equal] in + [MSetFullAVL]. The structural variants compute faster in Coq, + whereas the other variants produce nicer and/or (slightly) faster + code after extraction. +*) + +Require Import MSetInterface ZArith Int. + +Set Implicit Arguments. +Unset Strict Implicit. + +(** * Ops : the pure functions *) + +Module Ops (Import I:Int)(X:OrderedType) <: WOps X. +Local Open Scope Int_scope. +Local Open Scope lazy_bool_scope. + +Definition elt := X.t. + +(** ** Trees + + The fourth field of [Node] is the height of the tree *) + +Inductive tree := + | Leaf : tree + | Node : tree -> X.t -> tree -> int -> tree. + +Definition t := tree. + +(** ** Basic functions on trees: height and cardinal *) + +Definition height (s : t) : int := + match s with + | Leaf => 0 + | Node _ _ _ h => h + end. + +Fixpoint cardinal (s : t) : nat := + match s with + | Leaf => 0%nat + | Node l _ r _ => S (cardinal l + cardinal r) + end. + +(** ** Empty Set *) + +Definition empty := Leaf. + +(** ** Emptyness test *) + +Definition is_empty s := + match s with Leaf => true | _ => false end. + +(** ** Appartness *) + +(** The [mem] function is deciding appartness. It exploits the + binary search tree invariant to achieve logarithmic complexity. *) + +Fixpoint mem x s := + match s with + | Leaf => false + | Node l y r _ => match X.compare x y with + | Lt => mem x l + | Eq => true + | Gt => mem x r + end + end. + +(** ** Singleton set *) + +Definition singleton x := Node Leaf x Leaf 1. + +(** ** Helper functions *) + +(** [create l x r] creates a node, assuming [l] and [r] + to be balanced and [|height l - height r| <= 2]. *) + +Definition create l x r := + Node l x r (max (height l) (height r) + 1). + +(** [bal l x r] acts as [create], but performs one step of + rebalancing if necessary, i.e. assumes [|height l - height r| <= 3]. *) + +Definition assert_false := create. + +Definition bal l x r := + let hl := height l in + let hr := height r in + if gt_le_dec hl (hr+2) then + match l with + | Leaf => assert_false l x r + | Node ll lx lr _ => + if ge_lt_dec (height ll) (height lr) then + create ll lx (create lr x r) + else + match lr with + | Leaf => assert_false l x r + | Node lrl lrx lrr _ => + create (create ll lx lrl) lrx (create lrr x r) + end + end + else + if gt_le_dec hr (hl+2) then + match r with + | Leaf => assert_false l x r + | Node rl rx rr _ => + if ge_lt_dec (height rr) (height rl) then + create (create l x rl) rx rr + else + match rl with + | Leaf => assert_false l x r + | Node rll rlx rlr _ => + create (create l x rll) rlx (create rlr rx rr) + end + end + else + create l x r. + +(** ** Insertion *) + +Fixpoint add x s := match s with + | Leaf => Node Leaf x Leaf 1 + | Node l y r h => + match X.compare x y with + | Lt => bal (add x l) y r + | Eq => Node l y r h + | Gt => bal l y (add x r) + end + end. + +(** ** Join + + Same as [bal] but does not assume anything regarding heights + of [l] and [r]. +*) + +Fixpoint join l : elt -> t -> t := + match l with + | Leaf => add + | Node ll lx lr lh => fun x => + fix join_aux (r:t) : t := match r with + | Leaf => add x l + | Node rl rx rr rh => + if gt_le_dec lh (rh+2) then bal ll lx (join lr x r) + else if gt_le_dec rh (lh+2) then bal (join_aux rl) rx rr + else create l x r + end + end. + +(** ** Extraction of minimum element + + Morally, [remove_min] is to be applied to a non-empty tree + [t = Node l x r h]. Since we can't deal here with [assert false] + for [t=Leaf], we pre-unpack [t] (and forget about [h]). +*) + +Fixpoint remove_min l x r : t*elt := + match l with + | Leaf => (r,x) + | Node ll lx lr lh => + let (l',m) := remove_min ll lx lr in (bal l' x r, m) + end. + +(** ** Merging two trees + + [merge t1 t2] builds the union of [t1] and [t2] assuming all elements + of [t1] to be smaller than all elements of [t2], and + [|height t1 - height t2| <= 2]. +*) + +Definition merge s1 s2 := match s1,s2 with + | Leaf, _ => s2 + | _, Leaf => s1 + | _, Node l2 x2 r2 h2 => + let (s2',m) := remove_min l2 x2 r2 in bal s1 m s2' +end. + +(** ** Deletion *) + +Fixpoint remove x s := match s with + | Leaf => Leaf + | Node l y r h => + match X.compare x y with + | Lt => bal (remove x l) y r + | Eq => merge l r + | Gt => bal l y (remove x r) + end + end. + +(** ** Minimum element *) + +Fixpoint min_elt s := match s with + | Leaf => None + | Node Leaf y _ _ => Some y + | Node l _ _ _ => min_elt l +end. + +(** ** Maximum element *) + +Fixpoint max_elt s := match s with + | Leaf => None + | Node _ y Leaf _ => Some y + | Node _ _ r _ => max_elt r +end. + +(** ** Any element *) + +Definition choose := min_elt. + +(** ** Concatenation + + Same as [merge] but does not assume anything about heights. +*) + +Definition concat s1 s2 := + match s1, s2 with + | Leaf, _ => s2 + | _, Leaf => s1 + | _, Node l2 x2 r2 _ => + let (s2',m) := remove_min l2 x2 r2 in + join s1 m s2' + end. + +(** ** Splitting + + [split x s] returns a triple [(l, present, r)] where + - [l] is the set of elements of [s] that are [< x] + - [r] is the set of elements of [s] that are [> x] + - [present] is [true] if and only if [s] contains [x]. +*) + +Record triple := mktriple { t_left:t; t_in:bool; t_right:t }. +Notation "<< l , b , r >>" := (mktriple l b r) (at level 9). + +Fixpoint split x s : triple := match s with + | Leaf => << Leaf, false, Leaf >> + | Node l y r h => + match X.compare x y with + | Lt => let (ll,b,rl) := split x l in << ll, b, join rl y r >> + | Eq => << l, true, r >> + | Gt => let (rl,b,rr) := split x r in << join l y rl, b, rr >> + end + end. + +(** ** Intersection *) + +Fixpoint inter s1 s2 := match s1, s2 with + | Leaf, _ => Leaf + | _, Leaf => Leaf + | Node l1 x1 r1 h1, _ => + let (l2',pres,r2') := split x1 s2 in + if pres then join (inter l1 l2') x1 (inter r1 r2') + else concat (inter l1 l2') (inter r1 r2') + end. + +(** ** Difference *) + +Fixpoint diff s1 s2 := match s1, s2 with + | Leaf, _ => Leaf + | _, Leaf => s1 + | Node l1 x1 r1 h1, _ => + let (l2',pres,r2') := split x1 s2 in + if pres then concat (diff l1 l2') (diff r1 r2') + else join (diff l1 l2') x1 (diff r1 r2') +end. + +(** ** Union *) + +(** In ocaml, heights of [s1] and [s2] are compared each time in order + to recursively perform the split on the smaller set. + Unfortunately, this leads to a non-structural algorithm. The + following code is a simplification of the ocaml version: no + comparison of heights. It might be slightly slower, but + experimentally all the tests I've made in ocaml have shown this + potential slowdown to be non-significant. Anyway, the exact code + of ocaml has also been formalized thanks to Function+measure, see + [ocaml_union] in [MSetFullAVL]. +*) + +Fixpoint union s1 s2 := + match s1, s2 with + | Leaf, _ => s2 + | _, Leaf => s1 + | Node l1 x1 r1 h1, _ => + let (l2',_,r2') := split x1 s2 in + join (union l1 l2') x1 (union r1 r2') + end. + +(** ** Elements *) + +(** [elements_tree_aux acc t] catenates the elements of [t] in infix + order to the list [acc] *) + +Fixpoint elements_aux (acc : list X.t) (s : t) : list X.t := + match s with + | Leaf => acc + | Node l x r _ => elements_aux (x :: elements_aux acc r) l + end. + +(** then [elements] is an instanciation with an empty [acc] *) + +Definition elements := elements_aux nil. + +(** ** Filter *) + +Fixpoint filter_acc (f:elt->bool) acc s := match s with + | Leaf => acc + | Node l x r h => + filter_acc f (filter_acc f (if f x then add x acc else acc) l) r + end. + +Definition filter f := filter_acc f Leaf. + + +(** ** Partition *) + +Fixpoint partition_acc (f:elt->bool)(acc : t*t)(s : t) : t*t := + match s with + | Leaf => acc + | Node l x r _ => + let (acct,accf) := acc in + partition_acc f + (partition_acc f + (if f x then (add x acct, accf) else (acct, add x accf)) l) r + end. + +Definition partition f := partition_acc f (Leaf,Leaf). + +(** ** [for_all] and [exists] *) + +Fixpoint for_all (f:elt->bool) s := match s with + | Leaf => true + | Node l x r _ => f x &&& for_all f l &&& for_all f r +end. + +Fixpoint exists_ (f:elt->bool) s := match s with + | Leaf => false + | Node l x r _ => f x ||| exists_ f l ||| exists_ f r +end. + +(** ** Fold *) + +Fixpoint fold (A : Type) (f : elt -> A -> A)(s : t) : A -> A := + fun a => match s with + | Leaf => a + | Node l x r _ => fold f r (f x (fold f l a)) + end. +Implicit Arguments fold [A]. + + +(** ** Subset *) + +(** In ocaml, recursive calls are made on "half-trees" such as + (Node l1 x1 Leaf _) and (Node Leaf x1 r1 _). Instead of these + non-structural calls, we propose here two specialized functions for + these situations. This version should be almost as efficient as + the one of ocaml (closures as arguments may slow things a bit), + it is simply less compact. The exact ocaml version has also been + formalized (thanks to Function+measure), see [ocaml_subset] in + [MSetFullAVL]. + *) + +Fixpoint subsetl (subset_l1:t->bool) x1 s2 : bool := + match s2 with + | Leaf => false + | Node l2 x2 r2 h2 => + match X.compare x1 x2 with + | Eq => subset_l1 l2 + | Lt => subsetl subset_l1 x1 l2 + | Gt => mem x1 r2 &&& subset_l1 s2 + end + end. + +Fixpoint subsetr (subset_r1:t->bool) x1 s2 : bool := + match s2 with + | Leaf => false + | Node l2 x2 r2 h2 => + match X.compare x1 x2 with + | Eq => subset_r1 r2 + | Lt => mem x1 l2 &&& subset_r1 s2 + | Gt => subsetr subset_r1 x1 r2 + end + end. + +Fixpoint subset s1 s2 : bool := match s1, s2 with + | Leaf, _ => true + | Node _ _ _ _, Leaf => false + | Node l1 x1 r1 h1, Node l2 x2 r2 h2 => + match X.compare x1 x2 with + | Eq => subset l1 l2 &&& subset r1 r2 + | Lt => subsetl (subset l1) x1 l2 &&& subset r1 s2 + | Gt => subsetr (subset r1) x1 r2 &&& subset l1 s2 + end + end. + +(** ** A new comparison algorithm suggested by Xavier Leroy + + Transformation in C.P.S. suggested by Benjamin Grégoire. + The original ocaml code (with non-structural recursive calls) + has also been formalized (thanks to Function+measure), see + [ocaml_compare] in [MSetFullAVL]. The following code with + continuations computes dramatically faster in Coq, and + should be almost as efficient after extraction. +*) + +(** Enumeration of the elements of a tree *) + +Inductive enumeration := + | End : enumeration + | More : elt -> t -> enumeration -> enumeration. + + +(** [cons t e] adds the elements of tree [t] on the head of + enumeration [e]. *) + +Fixpoint cons s e : enumeration := + match s with + | Leaf => e + | Node l x r h => cons l (More x r e) + end. + +(** One step of comparison of elements *) + +Definition compare_more x1 (cont:enumeration->comparison) e2 := + match e2 with + | End => Gt + | More x2 r2 e2 => + match X.compare x1 x2 with + | Eq => cont (cons r2 e2) + | Lt => Lt + | Gt => Gt + end + end. + +(** Comparison of left tree, middle element, then right tree *) + +Fixpoint compare_cont s1 (cont:enumeration->comparison) e2 := + match s1 with + | Leaf => cont e2 + | Node l1 x1 r1 _ => + compare_cont l1 (compare_more x1 (compare_cont r1 cont)) e2 + end. + +(** Initial continuation *) + +Definition compare_end e2 := + match e2 with End => Eq | _ => Lt end. + +(** The complete comparison *) + +Definition compare s1 s2 := compare_cont s1 compare_end (cons s2 End). + +(** ** Equality test *) + +Definition equal s1 s2 : bool := + match compare s1 s2 with + | Eq => true + | _ => false + end. + +End Ops. + + + +(** * MakeRaw + + Functor of pure functions + a posteriori proofs of invariant + preservation *) + +Module MakeRaw (Import I:Int)(X:OrderedType) <: RawSets X. +Include Ops I X. + +(** * Invariants *) + +(** ** Occurrence in a tree *) + +Inductive InT (x : elt) : tree -> Prop := + | IsRoot : forall l r h y, X.eq x y -> InT x (Node l y r h) + | InLeft : forall l r h y, InT x l -> InT x (Node l y r h) + | InRight : forall l r h y, InT x r -> InT x (Node l y r h). + +Definition In := InT. + +(** ** Some shortcuts *) + +Definition Equal s s' := forall a : elt, InT a s <-> InT a s'. +Definition Subset s s' := forall a : elt, InT a s -> InT a s'. +Definition Empty s := forall a : elt, ~ InT a s. +Definition For_all (P : elt -> Prop) s := forall x, InT x s -> P x. +Definition Exists (P : elt -> Prop) s := exists x, InT x s /\ P x. + +(** ** Binary search trees *) + +(** [lt_tree x s]: all elements in [s] are smaller than [x] + (resp. greater for [gt_tree]) *) + +Definition lt_tree x s := forall y, InT y s -> X.lt y x. +Definition gt_tree x s := forall y, InT y s -> X.lt x y. + +(** [bst t] : [t] is a binary search tree *) + +Inductive bst : tree -> Prop := + | BSLeaf : bst Leaf + | BSNode : forall x l r h, bst l -> bst r -> + lt_tree x l -> gt_tree x r -> bst (Node l x r h). + +(** [bst] is the (decidable) invariant our trees will have to satisfy. *) + +Definition IsOk := bst. + +Class Ok (s:t) : Prop := { ok : bst s }. + +Instance bst_Ok `(Hs : bst s) : Ok s := Hs. + +Fixpoint ltb_tree x s := + match s with + | Leaf => true + | Node l y r _ => + match X.compare x y with + | Gt => ltb_tree x l && ltb_tree x r + | _ => false + end + end. + +Fixpoint gtb_tree x s := + match s with + | Leaf => true + | Node l y r _ => + match X.compare x y with + | Lt => gtb_tree x l && gtb_tree x r + | _ => false + end + end. + +Fixpoint isok s := + match s with + | Leaf => true + | Node l x r _ => isok l && isok r && ltb_tree x l && gtb_tree x r + end. + + +(** * Correctness proofs *) + +(* Module Proofs. *) + Module MX := OrderedTypeFacts X. + Hint Resolve MX.lt_trans. + +(** * Automation and dedicated tactics *) + +Hint Unfold In. +Hint Constructors InT bst. +Hint Unfold lt_tree gt_tree. +Hint Resolve @ok. +Hint Constructors Ok. + +Tactic Notation "factornode" ident(l) ident(x) ident(r) ident(h) + "as" ident(s) := + set (s:=Node l x r h) in *; clearbody s; clear l x r h. + +(** Automatic treatment of [Ok] hypothesis *) + +Ltac inv_ok := match goal with + | H:Ok (Node _ _ _ _) |- _ => apply @ok in H; inversion_clear H; inv_ok + | H:Ok Leaf |- _ => clear H; inv_ok + | H:bst _ |- _ => generalize (Build_Ok H); clear H; intro H; inv_ok + | _ => idtac +end. + +(** A tactic to repeat [inversion_clear] on all hyps of the + form [(f (Node _ _ _ _))] *) + +Ltac is_tree_constr c := + match c with + | Leaf => idtac + | Node _ _ _ _ => idtac + | _ => fail + end. + +Ltac invtree f := + match goal with + | H:f ?s |- _ => is_tree_constr s; inversion_clear H; invtree f + | H:f _ ?s |- _ => is_tree_constr s; inversion_clear H; invtree f + | H:f _ _ ?s |- _ => is_tree_constr s; inversion_clear H; invtree f + | _ => idtac + end. + +Ltac inv := inv_ok; invtree InT. + +Ltac intuition_in := repeat progress (intuition; inv). + +(** Helper tactic concerning order of elements. *) + +Ltac order := match goal with + | U: lt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order + | U: gt_tree _ ?s, V: InT _ ?s |- _ => generalize (U _ V); clear U; order + | _ => MX.order +end. + + +(** [isok] is indeed a decision procedure for [Ok] *) + +Lemma ltb_tree_iff : forall x s, lt_tree x s <-> ltb_tree x s = true. +Proof. + induction s as [|l IHl y r IHr h]; simpl. + unfold lt_tree; intuition_in. + MX.elim_compare x y; intros. + split; intros; try discriminate. assert (X.lt y x) by auto. order. + split; intros; try discriminate. assert (X.lt y x) by auto. order. + rewrite !andb_true_iff, <-IHl, <-IHr. + unfold lt_tree; intuition_in; order. +Qed. + +Lemma gtb_tree_iff : forall x s, gt_tree x s <-> gtb_tree x s = true. +Proof. + induction s as [|l IHl y r IHr h]; simpl. + unfold gt_tree; intuition_in. + MX.elim_compare x y; intros. + split; intros; try discriminate. assert (X.lt x y) by auto. order. + rewrite !andb_true_iff, <-IHl, <-IHr. + unfold gt_tree; intuition_in; order. + split; intros; try discriminate. assert (X.lt x y) by auto. order. +Qed. + +Lemma isok_iff : forall s, Ok s <-> isok s = true. +Proof. + induction s as [|l IHl y r IHr h]; simpl. + intuition_in. + rewrite !andb_true_iff, <- IHl, <-IHr, <- ltb_tree_iff, <- gtb_tree_iff. + intuition_in. +Qed. + +Instance isok_Ok `(isok s = true) : Ok s | 10. +Proof. intros; apply <- isok_iff; auto. Qed. + + +(** * Basic results about [In], [lt_tree], [gt_tree], [height] *) + +(** [In] is compatible with [X.eq] *) + +Lemma In_1 : + forall s x y, X.eq x y -> InT x s -> InT y s. +Proof. + induction s; simpl; intuition_in; eauto 3. (** TODO: why 5 is so slow ? *) +Qed. +Hint Immediate In_1. + +Instance In_compat : Proper (X.eq==>eq==>iff) InT. +Proof. +apply proper_sym_impl_iff_2; auto with *. +repeat red; intros; subst. apply In_1 with x; auto. +Qed. + +Lemma In_node_iff : + forall l x r h y, + InT y (Node l x r h) <-> InT y l \/ X.eq y x \/ InT y r. +Proof. + intuition_in. +Qed. + +(** Results about [lt_tree] and [gt_tree] *) + +Lemma lt_leaf : forall x : elt, lt_tree x Leaf. +Proof. + red; inversion 1. +Qed. + +Lemma gt_leaf : forall x : elt, gt_tree x Leaf. +Proof. + red; inversion 1. +Qed. + +Lemma lt_tree_node : + forall (x y : elt) (l r : tree) (h : int), + lt_tree x l -> lt_tree x r -> X.lt y x -> lt_tree x (Node l y r h). +Proof. + unfold lt_tree; intuition_in; order. +Qed. + +Lemma gt_tree_node : + forall (x y : elt) (l r : tree) (h : int), + gt_tree x l -> gt_tree x r -> X.lt x y -> gt_tree x (Node l y r h). +Proof. + unfold gt_tree; intuition_in; order. +Qed. + +Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node. + +Lemma lt_tree_not_in : + forall (x : elt) (t : tree), lt_tree x t -> ~ InT x t. +Proof. + intros; intro; order. +Qed. + +Lemma lt_tree_trans : + forall x y, X.lt x y -> forall t, lt_tree x t -> lt_tree y t. +Proof. + eauto. +Qed. + +Lemma gt_tree_not_in : + forall (x : elt) (t : tree), gt_tree x t -> ~ InT x t. +Proof. + intros; intro; order. +Qed. + +Lemma gt_tree_trans : + forall x y, X.lt y x -> forall t, gt_tree x t -> gt_tree y t. +Proof. + eauto. +Qed. + +Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans. + +(** * Inductions principles for some of the set operators *) + +Functional Scheme bal_ind := Induction for bal Sort Prop. +Functional Scheme remove_min_ind := Induction for remove_min Sort Prop. +Functional Scheme merge_ind := Induction for merge Sort Prop. +Functional Scheme min_elt_ind := Induction for min_elt Sort Prop. +Functional Scheme max_elt_ind := Induction for max_elt Sort Prop. +Functional Scheme concat_ind := Induction for concat Sort Prop. +Functional Scheme inter_ind := Induction for inter Sort Prop. +Functional Scheme diff_ind := Induction for diff Sort Prop. +Functional Scheme union_ind := Induction for union Sort Prop. + +Ltac induct s x := + induction s as [|l IHl x' r IHr h]; simpl; intros; + [|MX.elim_compare x x'; intros; inv]. + + +(** * Notations and helper lemma about pairs and triples *) + +Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. +Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. +Notation "t #l" := (t_left t) (at level 9, format "t '#l'") : pair_scope. +Notation "t #b" := (t_in t) (at level 9, format "t '#b'") : pair_scope. +Notation "t #r" := (t_right t) (at level 9, format "t '#r'") : pair_scope. + +Open Local Scope pair_scope. + + +(** * Empty set *) + +Lemma empty_spec : Empty empty. +Proof. + intro; intro. + inversion H. +Qed. + +Instance empty_ok : Ok empty. +Proof. + auto. +Qed. + +(** * Emptyness test *) + +Lemma is_empty_spec : forall s, is_empty s = true <-> Empty s. +Proof. + destruct s as [|r x l h]; simpl; auto. + split; auto. red; red; intros; inv. + split; auto. try discriminate. intro H; elim (H x); auto. +Qed. + +(** * Appartness *) + +Lemma mem_spec : forall s x `{Ok s}, mem x s = true <-> InT x s. +Proof. + split. + induct s x; auto; discriminate. + induct s x; intuition_in; order. +Qed. + + +(** * Singleton set *) + +Lemma singleton_spec : forall x y, InT y (singleton x) <-> X.eq y x. +Proof. + unfold singleton; intuition_in. +Qed. + +Instance singleton_ok x : Ok (singleton x). +Proof. + unfold singleton; auto. +Qed. + + + +(** * Helper functions *) + +Lemma create_spec : + forall l x r y, InT y (create l x r) <-> X.eq y x \/ InT y l \/ InT y r. +Proof. + unfold create; split; [ inversion_clear 1 | ]; intuition. +Qed. + +Instance create_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : + Ok (create l x r). +Proof. + unfold create; auto. +Qed. + +Lemma bal_spec : forall l x r y, + InT y (bal l x r) <-> X.eq y x \/ InT y l \/ InT y r. +Proof. + intros l x r; functional induction bal l x r; intros; try clear e0; + rewrite !create_spec; intuition_in. +Qed. + +Instance bal_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : + Ok (bal l x r). +Proof. + intros l x r; functional induction bal l x r; intros; + inv; repeat apply create_ok; auto; unfold create; + (apply lt_tree_node || apply gt_tree_node); auto; + (eapply lt_tree_trans || eapply gt_tree_trans); eauto. +Qed. + + +(** * Insertion *) + +Lemma add_spec' : forall s x y, + InT y (add x s) <-> X.eq y x \/ InT y s. +Proof. + induct s x; try rewrite ?bal_spec, ?IHl, ?IHr; intuition_in. + setoid_replace y with x'; eauto. +Qed. + +Lemma add_spec : forall s x y `{Ok s}, + InT y (add x s) <-> X.eq y x \/ InT y s. +Proof. intros; apply add_spec'. Qed. + +Instance add_ok s x `(Ok s) : Ok (add x s). +Proof. + induct s x; auto; apply bal_ok; auto. + (* lt_tree -> lt_tree (add ...) *) + red; red in H3. + intros. + rewrite add_spec' in H. + intuition. + eauto. + (* gt_tree -> gt_tree (add ...) *) + red; red in H3. + intros. + rewrite add_spec' in H. + intuition. + setoid_replace y with x; auto. +Qed. + + +Open Scope Int_scope. + +(** * Join *) + +(* Function/Functional Scheme can't deal with internal fix. + Let's do its job by hand: *) + +Ltac join_tac := + intro l; induction l as [| ll _ lx lr Hlr lh]; + [ | intros x r; induction r as [| rl Hrl rx rr _ rh]; unfold join; + [ | destruct (gt_le_dec lh (rh+2)); + [ match goal with |- context b [ bal ?a ?b ?c] => + replace (bal a b c) + with (bal ll lx (join lr x (Node rl rx rr rh))); [ | auto] + end + | destruct (gt_le_dec rh (lh+2)); + [ match goal with |- context b [ bal ?a ?b ?c] => + replace (bal a b c) + with (bal (join (Node ll lx lr lh) x rl) rx rr); [ | auto] + end + | ] ] ] ]; intros. + +Lemma join_spec : forall l x r y, + InT y (join l x r) <-> X.eq y x \/ InT y l \/ InT y r. +Proof. + join_tac. + simpl. + rewrite add_spec'; intuition_in. + rewrite add_spec'; intuition_in. + rewrite bal_spec, Hlr; clear Hlr Hrl; intuition_in. + rewrite bal_spec, Hrl; clear Hlr Hrl; intuition_in. + apply create_spec. +Qed. + +Instance join_ok l x r `(Ok l, Ok r, lt_tree x l, gt_tree x r) : + Ok (join l x r). +Proof. + join_tac; auto with *; inv; apply bal_ok; auto; + clear Hrl Hlr z; intro; intros; rewrite join_spec in *. + intuition; [ setoid_replace y with x | ]; eauto. + intuition; [ setoid_replace y with x | ]; eauto. +Qed. + + +(** * Extraction of minimum element *) + +Lemma remove_min_spec : forall l x r h y, + InT y (Node l x r h) <-> + X.eq y (remove_min l x r)#2 \/ InT y (remove_min l x r)#1. +Proof. + intros l x r; functional induction (remove_min l x r); simpl in *; intros. + intuition_in. + rewrite bal_spec, In_node_iff, IHp, e0; simpl; intuition. +Qed. + +Instance remove_min_ok l x r h `(Ok (Node l x r h)) : + Ok (remove_min l x r)#1. +Proof. + intros l x r; functional induction (remove_min l x r); simpl; intros. + inv; auto. + assert (O : Ok (Node ll lx lr _x)) by (inv; auto). + assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto). + specialize IHp with (1:=O); rewrite e0 in IHp; auto; simpl in *. + apply bal_ok; auto. + inv; auto. + intro y; specialize (L y). + rewrite remove_min_spec, e0 in L; simpl in L; intuition. + inv; auto. +Qed. + +Lemma remove_min_gt_tree : forall l x r h `{Ok (Node l x r h)}, + gt_tree (remove_min l x r)#2 (remove_min l x r)#1. +Proof. + intros l x r; functional induction (remove_min l x r); simpl; intros. + inv; auto. + assert (O : Ok (Node ll lx lr _x)) by (inv; auto). + assert (L : lt_tree x (Node ll lx lr _x)) by (inv; auto). + specialize IHp with (1:=O); rewrite e0 in IHp; simpl in IHp. + intro y; rewrite bal_spec; intuition; + specialize (L m); rewrite remove_min_spec, e0 in L; simpl in L; + [setoid_replace y with x|inv]; eauto. +Qed. +Hint Resolve remove_min_gt_tree. + + + +(** * Merging two trees *) + +Lemma merge_spec : forall s1 s2 y, + InT y (merge s1 s2) <-> InT y s1 \/ InT y s2. +Proof. + intros s1 s2; functional induction (merge s1 s2); intros; + try factornode _x _x0 _x1 _x2 as s1. + intuition_in. + intuition_in. + rewrite bal_spec, remove_min_spec, e1; simpl; intuition. +Qed. + +Instance merge_ok s1 s2 `(Ok s1, Ok s2) + `(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2) : + Ok (merge s1 s2). +Proof. + intros s1 s2; functional induction (merge s1 s2); intros; auto; + try factornode _x _x0 _x1 _x2 as s1. + apply bal_ok; auto. + change s2' with ((s2',m)#1); rewrite <-e1; eauto with *. + intros y Hy. + apply H1; auto. + rewrite remove_min_spec, e1; simpl; auto. + change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto. +Qed. + + + +(** * Deletion *) + +Lemma remove_spec : forall s x y `{Ok s}, + (InT y (remove x s) <-> InT y s /\ ~ X.eq y x). +Proof. + induct s x. + intuition_in. + rewrite merge_spec; intuition; [order|order|intuition_in]. + elim H6; eauto. + rewrite bal_spec, IHl; clear IHl IHr; intuition; [order|order|intuition_in]. + rewrite bal_spec, IHr; clear IHl IHr; intuition; [order|order|intuition_in]. +Qed. + +Instance remove_ok s x `(Ok s) : Ok (remove x s). +Proof. + induct s x. + auto. + (* EQ *) + apply merge_ok; eauto. + (* LT *) + apply bal_ok; auto. + intro z; rewrite remove_spec; auto; destruct 1; eauto. + (* GT *) + apply bal_ok; auto. + intro z; rewrite remove_spec; auto; destruct 1; eauto. +Qed. + + +(** * Minimum element *) + +Lemma min_elt_spec1 : forall s x, min_elt s = Some x -> InT x s. +Proof. + intro s; functional induction (min_elt s); auto; inversion 1; auto. +Qed. + +Lemma min_elt_spec2 : forall s x y `{Ok s}, + min_elt s = Some x -> InT y s -> ~ X.lt y x. +Proof. + intro s; functional induction (min_elt s); + try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. + discriminate. + intros x y0 U V W. + inversion V; clear V; subst. + inv; auto. + intros; inv; auto. + assert (X.lt x y) by (apply H4; apply min_elt_spec1; auto). + order. + assert (X.lt x1 y) by auto. + assert (~X.lt x1 x) by auto. + order. +Qed. + +Lemma min_elt_spec3 : forall s, min_elt s = None -> Empty s. +Proof. + intro s; functional induction (min_elt s). + red; red; inversion 2. + inversion 1. + intro H0. + destruct (IHo H0 _x2); auto. +Qed. + + + +(** * Maximum element *) + +Lemma max_elt_spec1 : forall s x, max_elt s = Some x -> InT x s. +Proof. + intro s; functional induction (max_elt s); auto; inversion 1; auto. +Qed. + +Lemma max_elt_spec2 : forall s x y `{Ok s}, + max_elt s = Some x -> InT y s -> ~ X.lt x y. +Proof. + intro s; functional induction (max_elt s); + try rename _x1 into l1, _x2 into x1, _x3 into r1, _x4 into h1. + discriminate. + intros x y0 U V W. + inversion V; clear V; subst. + inv; auto. + intros; inv; auto. + assert (X.lt y x1) by auto. + assert (~ X.lt x x1) by auto. + order. + assert (X.lt y x) by (apply H5; apply max_elt_spec1; auto). + order. +Qed. + +Lemma max_elt_spec3 : forall s, max_elt s = None -> Empty s. +Proof. + intro s; functional induction (max_elt s). + red; auto. + inversion 1. + intros H0; destruct (IHo H0 _x2); auto. +Qed. + + + +(** * Any element *) + +Lemma choose_spec1 : forall s x, choose s = Some x -> InT x s. +Proof. + exact min_elt_spec1. +Qed. + +Lemma choose_spec2 : forall s, choose s = None -> Empty s. +Proof. + exact min_elt_spec3. +Qed. + +Lemma choose_spec3 : forall s s' x x' `{Ok s, Ok s'}, + choose s = Some x -> choose s' = Some x' -> + Equal s s' -> X.eq x x'. +Proof. + unfold choose, Equal; intros s s' x x' Hb Hb' Hx Hx' H. + assert (~X.lt x x'). + apply min_elt_spec2 with s'; auto. + rewrite <-H; auto using min_elt_spec1. + assert (~X.lt x' x). + apply min_elt_spec2 with s; auto. + rewrite H; auto using min_elt_spec1. + MX.elim_compare x x'; intuition. +Qed. + + +(** * Concatenation *) + +Lemma concat_spec : forall s1 s2 y, + InT y (concat s1 s2) <-> InT y s1 \/ InT y s2. +Proof. + intros s1 s2; functional induction (concat s1 s2); intros; + try factornode _x _x0 _x1 _x2 as s1. + intuition_in. + intuition_in. + rewrite join_spec, remove_min_spec, e1; simpl; intuition. +Qed. + +Instance concat_ok s1 s2 `(Ok s1, Ok s2) + `(forall y1 y2 : elt, InT y1 s1 -> InT y2 s2 -> X.lt y1 y2) : + Ok (concat s1 s2). +Proof. + intros s1 s2; functional induction (concat s1 s2); intros; auto; + try factornode _x _x0 _x1 _x2 as s1. + apply join_ok; auto. + change (Ok (s2',m)#1); rewrite <-e1; eauto with *. + intros y Hy. + apply H1; auto. + rewrite remove_min_spec, e1; simpl; auto. + change (gt_tree (s2',m)#2 (s2',m)#1); rewrite <-e1; eauto. +Qed. + + + +(** * Splitting *) + +Lemma split_spec1 : forall s x y `{Ok s}, + (InT y (split x s)#l <-> InT y s /\ X.lt y x). +Proof. + induct s x. + intuition_in. + intuition_in; order. + specialize (IHl x y). + destruct (split x l); simpl in *. rewrite IHl; intuition_in; order. + specialize (IHr x y). + destruct (split x r); simpl in *. rewrite join_spec, IHr; intuition_in; order. +Qed. + +Lemma split_spec2 : forall s x y `{Ok s}, + (InT y (split x s)#r <-> InT y s /\ X.lt x y). +Proof. + induct s x. + intuition_in. + intuition_in; order. + specialize (IHl x y). + destruct (split x l); simpl in *. rewrite join_spec, IHl; intuition_in; order. + specialize (IHr x y). + destruct (split x r); simpl in *. rewrite IHr; intuition_in; order. +Qed. + +Lemma split_spec3 : forall s x `{Ok s}, + ((split x s)#b = true <-> InT x s). +Proof. + induct s x. + intuition_in; try discriminate. + intuition. + specialize (IHl x). + destruct (split x l); simpl in *. rewrite IHl; intuition_in; order. + specialize (IHr x). + destruct (split x r); simpl in *. rewrite IHr; intuition_in; order. +Qed. + +Lemma split_ok s x `{Ok s} : Ok (split x s)#l /\ Ok (split x s)#r. +Proof. + induct s x; simpl; auto. + specialize (IHl x). + generalize (fun y => @split_spec2 _ x y H1). + destruct (split x l); simpl in *; intuition. apply join_ok; auto. + intros y; rewrite H; intuition. + specialize (IHr x). + generalize (fun y => @split_spec1 _ x y H2). + destruct (split x r); simpl in *; intuition. apply join_ok; auto. + intros y; rewrite H; intuition. +Qed. + +Instance split_ok1 s x `(Ok s) : Ok (split x s)#l. +Proof. intros; destruct (@split_ok s x); auto. Qed. + +Instance split_ok2 s x `(Ok s) : Ok (split x s)#r. +Proof. intros; destruct (@split_ok s x); auto. Qed. + + +(** * Intersection *) + +Ltac destruct_split := match goal with + | H : split ?x ?s = << ?u, ?v, ?w >> |- _ => + assert ((split x s)#l = u) by (rewrite H; auto); + assert ((split x s)#b = v) by (rewrite H; auto); + assert ((split x s)#r = w) by (rewrite H; auto); + clear H; subst u w + end. + +Lemma inter_spec_ok : forall s1 s2 `{Ok s1, Ok s2}, + Ok (inter s1 s2) /\ (forall y, InT y (inter s1 s2) <-> InT y s1 /\ InT y s2). +Proof. + intros s1 s2; functional induction inter s1 s2; intros B1 B2; + [intuition_in|intuition_in | | ]; + factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv; + destruct IHt0 as (IHo1,IHi1), IHt1 as (IHo2,IHi2); auto with *; + split; intros. + (* Ok join *) + apply join_ok; auto with *; intro y; rewrite ?IHi1, ?IHi2; intuition. + (* InT join *) + rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in. + setoid_replace y with x1; auto. rewrite <- split_spec3; auto. + (* Ok concat *) + apply concat_ok; auto with *; intros y1 y2; rewrite IHi1, IHi2; intuition; order. + (* InT concat *) + rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; auto. + intuition_in. + absurd (InT x1 s2). + rewrite <- split_spec3; auto; congruence. + setoid_replace x1 with y; auto. +Qed. + +Lemma inter_spec : forall s1 s2 y `{Ok s1, Ok s2}, + (InT y (inter s1 s2) <-> InT y s1 /\ InT y s2). +Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed. + +Instance inter_ok s1 s2 `(Ok s1, Ok s2) : Ok (inter s1 s2). +Proof. intros; destruct (@inter_spec_ok s1 s2); auto. Qed. + + +(** * Difference *) + +Lemma diff_spec_ok : forall s1 s2 `{Ok s1, Ok s2}, + Ok (diff s1 s2) /\ (forall y, InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2). +Proof. + intros s1 s2; functional induction diff s1 s2; intros B1 B2; + [intuition_in|intuition_in | | ]; + factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv; + destruct IHt0 as (IHb1,IHi1), IHt1 as (IHb2,IHi2); auto with *; + split; intros. + (* Ok concat *) + apply concat_ok; auto; intros y1 y2; rewrite IHi1, IHi2; intuition; order. + (* InT concat *) + rewrite concat_spec, IHi1, IHi2, split_spec1, split_spec2; intuition_in. + absurd (InT x1 s2). + setoid_replace x1 with y; auto. + rewrite <- split_spec3; auto; congruence. + (* Ok join *) + apply join_ok; auto; intro y; rewrite ?IHi1, ?IHi2; intuition. + (* InT join *) + rewrite join_spec, IHi1, IHi2, split_spec1, split_spec2; auto with *. + intuition_in. + absurd (InT x1 s2); auto. + rewrite <- split_spec3; auto; congruence. + setoid_replace x1 with y; auto. +Qed. + +Lemma diff_spec : forall s1 s2 y `{Ok s1, Ok s2}, + (InT y (diff s1 s2) <-> InT y s1 /\ ~InT y s2). +Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed. + +Instance diff_ok s1 s2 `(Ok s1, Ok s2) : Ok (diff s1 s2). +Proof. intros; destruct (@diff_spec_ok s1 s2); auto. Qed. + + +(** * Union *) + +Lemma union_spec : forall s1 s2 y `{Ok s1, Ok s2}, + (InT y (union s1 s2) <-> InT y s1 \/ InT y s2). +Proof. + intros s1 s2; functional induction union s1 s2; intros y B1 B2. + intuition_in. + intuition_in. + factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv. + rewrite join_spec, IHt0, IHt1, split_spec1, split_spec2; auto with *. + MX.elim_compare y x1; intuition_in. +Qed. + +Instance union_ok s1 s2 `(Ok s1, Ok s2) : Ok (union s1 s2). +Proof. + intros s1 s2; functional induction union s1 s2; intros B1 B2; auto. + factornode _x0 _x1 _x2 _x3 as s2; destruct_split; inv. + apply join_ok; auto with *. + intro y; rewrite union_spec, split_spec1; intuition_in. + intro y; rewrite union_spec, split_spec2; intuition_in. +Qed. + + +(** * Elements *) + +Lemma elements_spec1' : forall s acc x, + InA X.eq x (elements_aux acc s) <-> InT x s \/ InA X.eq x acc. +Proof. + induction s as [ | l Hl x r Hr h ]; simpl; auto. + intuition. + inversion H0. + intros. + rewrite Hl. + destruct (Hr acc x0); clear Hl Hr. + intuition; inversion_clear H3; intuition. +Qed. + +Lemma elements_spec1 : forall s x, InA X.eq x (elements s) <-> InT x s. +Proof. + intros; generalize (elements_spec1' s nil x); intuition. + inversion_clear H0. +Qed. + +Lemma elements_spec2' : forall s acc `{Ok s}, sort X.lt acc -> + (forall x y : elt, InA X.eq x acc -> InT y s -> X.lt y x) -> + sort X.lt (elements_aux acc s). +Proof. + induction s as [ | l Hl y r Hr h]; simpl; intuition. + inv. + apply Hl; auto. + constructor. + apply Hr; auto. + apply MX.In_Inf; intros. + destruct (elements_spec1' r acc y0); intuition. + intros. + inversion_clear H. + order. + destruct (elements_spec1' r acc x); intuition eauto. +Qed. + +Lemma elements_spec2 : forall s `(Ok s), sort X.lt (elements s). +Proof. + intros; unfold elements; apply elements_spec2'; auto. + intros; inversion H0. +Qed. +Hint Resolve elements_spec2. + +Lemma elements_spec2w : forall s `(Ok s), NoDupA X.eq (elements s). +Proof. + auto. +Qed. + +Lemma elements_aux_cardinal : + forall s acc, (length acc + cardinal s)%nat = length (elements_aux acc s). +Proof. + simple induction s; simpl in |- *; intuition. + rewrite <- H. + simpl in |- *. + rewrite <- H0; omega. +Qed. + +Lemma elements_cardinal : forall s : tree, cardinal s = length (elements s). +Proof. + exact (fun s => elements_aux_cardinal s nil). +Qed. + +Definition cardinal_spec (s:t)(Hs:Ok s) := elements_cardinal s. + +Lemma elements_app : + forall s acc, elements_aux acc s = elements s ++ acc. +Proof. + induction s; simpl; intros; auto. + rewrite IHs1, IHs2. + unfold elements; simpl. + rewrite 2 IHs1, IHs2, <- !app_nil_end, !app_ass; auto. +Qed. + +Lemma elements_node : + forall l x r h acc, + elements l ++ x :: elements r ++ acc = + elements (Node l x r h) ++ acc. +Proof. + unfold elements; simpl; intros; auto. + rewrite !elements_app, <- !app_nil_end, !app_ass; auto. +Qed. + + +(** * Filter *) + +Lemma filter_spec' : forall s x acc f, + Proper (X.eq==>eq) f -> + (InT x (filter_acc f acc s) <-> InT x acc \/ InT x s /\ f x = true). +Proof. + induction s; simpl; intros. + intuition_in. + rewrite IHs2, IHs1 by (destruct (f t0); auto). + case_eq (f t0); intros. + rewrite add_spec'; auto. + intuition_in. + rewrite (H _ _ H2). + intuition. + intuition_in. + rewrite (H _ _ H2) in H3. + rewrite H0 in H3; discriminate. +Qed. + +Instance filter_ok' s acc f `(Ok s, Ok acc) : + Ok (filter_acc f acc s). +Proof. + induction s; simpl; auto. + intros. inv. + destruct (f t0); auto with *. +Qed. + +Lemma filter_spec : forall s x f, + Proper (X.eq==>eq) f -> + (InT x (filter f s) <-> InT x s /\ f x = true). +Proof. + unfold filter; intros; rewrite filter_spec'; intuition_in. +Qed. + +Instance filter_ok s f `(Ok s) : Ok (filter f s). +Proof. + unfold filter; intros; apply filter_ok'; auto. +Qed. + + +(** * Partition *) + +Lemma partition_spec1' : forall s acc f, + Proper (X.eq==>eq) f -> forall x : elt, + InT x (partition_acc f acc s)#1 <-> + InT x acc#1 \/ InT x s /\ f x = true. +Proof. + induction s; simpl; intros. + intuition_in. + destruct acc as [acct accf]; simpl in *. + rewrite IHs2 by + (destruct (f t0); auto; apply partition_acc_avl_1; simpl; auto). + rewrite IHs1 by (destruct (f t0); simpl; auto). + case_eq (f t0); simpl; intros. + rewrite add_spec'; auto. + intuition_in. + rewrite (H _ _ H2). + intuition. + intuition_in. + rewrite (H _ _ H2) in H3. + rewrite H0 in H3; discriminate. +Qed. + +Lemma partition_spec2' : forall s acc f, + Proper (X.eq==>eq) f -> forall x : elt, + InT x (partition_acc f acc s)#2 <-> + InT x acc#2 \/ InT x s /\ f x = false. +Proof. + induction s; simpl; intros. + intuition_in. + destruct acc as [acct accf]; simpl in *. + rewrite IHs2 by + (destruct (f t0); auto; apply partition_acc_avl_2; simpl; auto). + rewrite IHs1 by (destruct (f t0); simpl; auto). + case_eq (f t0); simpl; intros. + intuition. + intuition_in. + rewrite (H _ _ H2) in H3. + rewrite H0 in H3; discriminate. + rewrite add_spec'; auto. + intuition_in. + rewrite (H _ _ H2). + intuition. +Qed. + +Lemma partition_spec1 : forall s f, + Proper (X.eq==>eq) f -> + Equal (partition f s)#1 (filter f s). +Proof. + unfold partition; intros s f P x. + rewrite partition_spec1', filter_spec; simpl; intuition_in. +Qed. + +Lemma partition_spec2 : forall s f, + Proper (X.eq==>eq) f -> + Equal (partition f s)#2 (filter (fun x => negb (f x)) s). +Proof. + unfold partition; intros s f P x. + rewrite partition_spec2', filter_spec; simpl; intuition_in. + rewrite H1; auto. + right; split; auto. + rewrite negb_true_iff in H1; auto. + intros u v H; rewrite H; auto. +Qed. + +Instance partition_ok1' s acc f `(Ok s, Ok acc#1) : + Ok (partition_acc f acc s)#1. +Proof. + induction s; simpl; auto. + destruct acc as [acct accf]; simpl in *. + intros. inv. + destruct (f t0); auto. + apply IHs2; simpl; auto. + apply IHs1; simpl; auto with *. +Qed. + +Instance partition_ok2' s acc f `(Ok s, Ok acc#2) : + Ok (partition_acc f acc s)#2. +Proof. + induction s; simpl; auto. + destruct acc as [acct accf]; simpl in *. + intros. inv. + destruct (f t0); auto. + apply IHs2; simpl; auto. + apply IHs1; simpl; auto with *. +Qed. + +Instance partition_ok1 s f `(Ok s) : Ok (partition f s)#1. +Proof. intros; apply partition_ok1'; auto. Qed. + +Instance partition_ok2 s f `(Ok s) : Ok (partition f s)#2. +Proof. intros; apply partition_ok2'; auto. Qed. + + + +(** * [for_all] and [exists] *) + +Lemma for_all_spec : forall s f, Proper (X.eq==>eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). +Proof. + split. + induction s; simpl; auto; intros; red; intros; inv. + destruct (andb_prop _ _ H0); auto. + destruct (andb_prop _ _ H1); eauto. + apply IHs1; auto. + destruct (andb_prop _ _ H0); auto. + destruct (andb_prop _ _ H1); auto. + apply IHs2; auto. + destruct (andb_prop _ _ H0); auto. + (* <- *) + induction s; simpl; auto. + intros. + rewrite IHs1; try red; auto. + rewrite IHs2; try red; auto. + generalize (H0 t0). + destruct (f t0); simpl; auto. +Qed. + +Lemma exists_spec : forall s f, Proper (X.eq==>eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). +Proof. + split. + induction s; simpl; intros; rewrite <- ?orb_lazy_alt in *. + discriminate. + destruct (orb_true_elim _ _ H0) as [H1|H1]. + destruct (orb_true_elim _ _ H1) as [H2|H2]. + exists t0; auto. + destruct (IHs1 H2); auto; exists x; intuition. + destruct (IHs2 H1); auto; exists x; intuition. + (* <- *) + induction s; simpl; destruct 1 as (x,(U,V)); inv; rewrite <- ?orb_lazy_alt. + rewrite (H _ _ (MX.eq_sym H0)); rewrite V; auto. + apply orb_true_intro; left. + apply orb_true_intro; right; apply IHs1; auto; exists x; auto. + apply orb_true_intro; right; apply IHs2; auto; exists x; auto. +Qed. + + +(** * Fold *) + +Lemma fold_spec' : + forall (A : Type) (f : elt -> A -> A) (s : tree) (i : A) (acc : list elt), + fold_left (flip f) (elements_aux acc s) i = fold_left (flip f) acc (fold f s i). +Proof. + induction s as [|l IHl x r IHr h]; simpl; intros; auto. + rewrite IHl. + simpl. unfold flip at 2. + apply IHr. +Qed. + +Lemma fold_spec : + forall (s:t) (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. +Proof. + unfold elements. + induction s as [|l IHl x r IHr h]; simpl; intros; auto. + rewrite fold_spec'. + rewrite IHr. + simpl; auto. +Qed. + + +(** * Subset *) + +Lemma subsetl_spec : forall subset_l1 l1 x1 h1 s2 + `{Ok (Node l1 x1 Leaf h1), Ok s2}, + (forall s `{Ok s}, (subset_l1 s = true <-> Subset l1 s)) -> + (subsetl subset_l1 x1 s2 = true <-> Subset (Node l1 x1 Leaf h1) s2 ). +Proof. + induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. + unfold Subset; intuition; try discriminate. + assert (H': InT x1 Leaf) by auto; inversion H'. + specialize (IHl2 H). + specialize (IHr2 H). + inv. + MX.elim_compare x1 x2; intros. + + rewrite H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite IHl2 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + constructor 3. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. + rewrite mem_spec; auto. + assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order. +Qed. + + +Lemma subsetr_spec : forall subset_r1 r1 x1 h1 s2, + bst (Node Leaf x1 r1 h1) -> bst s2 -> + (forall s, bst s -> (subset_r1 s = true <-> Subset r1 s)) -> + (subsetr subset_r1 x1 s2 = true <-> Subset (Node Leaf x1 r1 h1) s2). +Proof. + induction s2 as [|l2 IHl2 x2 r2 IHr2 h2]; simpl; intros. + unfold Subset; intuition; try discriminate. + assert (H': InT x1 Leaf) by auto; inversion H'. + specialize (IHl2 H). + specialize (IHr2 H). + inv. + MX.elim_compare x1 x2; intros. + + rewrite H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, H1 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + constructor 2. setoid_replace a with x1; auto. rewrite <- mem_spec; auto. + rewrite mem_spec; auto. + assert (InT x1 (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite IHr2 by auto; clear H1 IHl2 IHr2. + unfold Subset. intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. +Qed. + +Lemma subset_spec : forall s1 s2 `{Ok s1, Ok s2}, + (subset s1 s2 = true <-> Subset s1 s2). +Proof. + induction s1 as [|l1 IHl1 x1 r1 IHr1 h1]; simpl; intros. + unfold Subset; intuition_in. + destruct s2 as [|l2 x2 r2 h2]; simpl; intros. + unfold Subset; intuition_in; try discriminate. + assert (H': InT x1 Leaf) by auto; inversion H'. + inv. + MX.elim_compare x1 x2; intros. + + rewrite <-andb_lazy_alt, andb_true_iff, IHl1, IHr1 by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + assert (X.eq a x2) by order; intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, IHr1 by auto. + rewrite (@subsetl_spec (subset l1) l1 x1 h1) by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + + rewrite <-andb_lazy_alt, andb_true_iff, IHl1 by auto. + rewrite (@subsetr_spec (subset r1) r1 x1 h1) by auto. + clear IHl1 IHr1. + unfold Subset; intuition_in. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. + assert (InT a (Node l2 x2 r2 h2)) by auto; intuition_in; order. +Qed. + + +(** * Comparison *) + +(** ** Relations [eq] and [lt] over trees *) + +Module L := MakeListOrdering X. + +Definition eq := Equal. +Instance eq_equiv : Equivalence eq. +Proof. firstorder. Qed. + +Lemma eq_Leq : forall s s', eq s s' <-> L.eq (elements s) (elements s'). +Proof. + unfold eq, Equal, L.eq; intros. + setoid_rewrite elements_spec1; firstorder. +Qed. + +Definition lt (s1 s2 : t) : Prop := + exists s1', exists s2', Ok s1' /\ Ok s2' /\ eq s1 s1' /\ eq s2 s2' + /\ L.lt (elements s1') (elements s2'). + +Instance lt_strorder : StrictOrder lt. +Proof. + split. + intros s (s1 & s2 & B1 & B2 & E1 & E2 & L). + assert (eqlistA X.eq (elements s1) (elements s2)). + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. + rewrite <- eq_Leq. transitivity s; auto. symmetry; auto. + rewrite H in L. + apply (StrictOrder_Irreflexive (elements s2)); auto. + intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12) + (s2'' & s3' & B2' & B3 & E2' & E3 & L23). + exists s1', s3'; do 4 (split; trivial). + assert (eqlistA X.eq (elements s2') (elements s2'')). + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto with *. + rewrite <- eq_Leq. transitivity s2; auto. symmetry; auto. + transitivity (elements s2'); auto. + rewrite H; auto. +Qed. + +Instance lt_compat : Proper (eq==>eq==>iff) lt. +Proof. + intros s1 s2 E12 s3 s4 E34. split. + intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. transitivity s1; auto. symmetry; auto. + split; auto. transitivity s3; auto. symmetry; auto. + intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. transitivity s2; auto. + split; auto. transitivity s4; auto. +Qed. + + +(** * Proof of the comparison algorithm *) + +(** [flatten_e e] returns the list of elements of [e] i.e. the list + of elements actually compared *) + +Fixpoint flatten_e (e : enumeration) : list elt := match e with + | End => nil + | More x t r => x :: elements t ++ flatten_e r + end. + +Lemma flatten_e_elements : + forall l x r h e, + elements l ++ flatten_e (More x r e) = elements (Node l x r h) ++ flatten_e e. +Proof. + intros; simpl; apply elements_node. +Qed. + +Lemma cons_1 : forall s e, + flatten_e (cons s e) = elements s ++ flatten_e e. +Proof. + induction s; simpl; auto; intros. + rewrite IHs1; apply flatten_e_elements. +Qed. + +Hint Unfold flip. + +(** Correctness of this comparison *) + +Definition LCmp := Cmp L.eq L.lt. + +Lemma compare_end_Cmp : + forall e2, LCmp (compare_end e2) nil (flatten_e e2). +Proof. + destruct e2; simpl; auto. reflexivity. +Qed. + +Lemma compare_more_Cmp : forall x1 cont x2 r2 e2 l, + LCmp (cont (cons r2 e2)) l (elements r2 ++ flatten_e e2) -> + LCmp (compare_more x1 cont (More x2 r2 e2)) (x1::l) + (flatten_e (More x2 r2 e2)). +Proof. + simpl; intros; MX.elim_compare x1 x2; simpl; auto. + intros; apply L.cons_Cmp; auto. +Qed. + +Lemma compare_cont_Cmp : forall s1 cont e2 l, + (forall e, LCmp (cont e) l (flatten_e e)) -> + LCmp (compare_cont s1 cont e2) (elements s1 ++ l) (flatten_e e2). +Proof. + induction s1 as [|l1 Hl1 x1 r1 Hr1 h1]; simpl; intros; auto. + rewrite <- elements_node; simpl. + apply Hl1; auto. clear e2. intros [|x2 r2 e2]. + simpl; auto. + apply compare_more_Cmp. + rewrite <- cons_1; auto. +Qed. + +Lemma compare_Cmp : forall s1 s2, + LCmp (compare s1 s2) (elements s1) (elements s2). +Proof. + intros; unfold compare. + rewrite (app_nil_end (elements s1)). + replace (elements s2) with (flatten_e (cons s2 End)) by + (rewrite cons_1; simpl; rewrite <- app_nil_end; auto). + apply compare_cont_Cmp; auto. + intros. + apply compare_end_Cmp; auto. +Qed. + +Lemma compare_spec : forall s1 s2 `{Ok s1, Ok s2}, + Cmp eq lt (compare s1 s2) s1 s2. +Proof. + intros. + generalize (compare_Cmp s1 s2). + destruct (compare s1 s2); unfold LCmp, Cmp, flip; auto. + rewrite eq_Leq; auto. + intros; exists s1, s2; repeat split; auto. + intros; exists s2, s1; repeat split; auto. +Qed. + + +(** * Equality test *) + +Lemma equal_spec : forall s1 s2 `{Ok s1, Ok s2}, + equal s1 s2 = true <-> eq s1 s2. +Proof. +unfold equal; intros s1 s2 B1 B2. +generalize (@compare_spec s1 s2 B1 B2). +destruct (compare s1 s2); simpl; split; intros E; auto; try discriminate. +rewrite E in H. elim (StrictOrder_Irreflexive s2); auto. +rewrite E in H. elim (StrictOrder_Irreflexive s2); auto. +Qed. + +End MakeRaw. + + + +(** * Encapsulation + + Now, in order to really provide a functor implementing [S], we + need to encapsulate everything into a type of binary search trees. + They also happen to be well-balanced, but this has no influence + on the correctness of operations, so we won't state this here, + see [MSetFullAVL] if you need more than just the MSet interface. +*) + +Module IntMake (I:Int)(X: OrderedType) <: S with Module E := X. + Module Raw := MakeRaw I X. + Include Raw2Sets X Raw. +End IntMake. + +(* For concrete use inside Coq, we propose an instantiation of [Int] by [Z]. *) + +Module Make (X: OrderedType) <: S with Module E := X + :=IntMake(Z_as_Int)(X). diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v new file mode 100644 index 0000000000..884ed42353 --- /dev/null +++ b/theories/MSets/MSetDecide.v @@ -0,0 +1,864 @@ +(***********************************************************************) +(* 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$ *) + +(**************************************************************) +(* MSetDecide.v *) +(* *) +(* Author: Aaron Bohannon *) +(**************************************************************) + +(** This file implements a decision procedure for a certain + class of propositions involving finite sets. *) + +Require Import Decidable DecidableTypeEx MSetFacts. + +(** First, a version for Weak Sets in functorial presentation *) + +Module WDecideOn (E : DecidableType)(Import M : WSetsOn E). + Module F := MSetFacts.WFactsOn E M. + +(** * Overview + This functor defines the tactic [fsetdec], which will + solve any valid goal of the form +<< + forall s1 ... sn, + forall x1 ... xm, + P1 -> ... -> Pk -> P +>> + where [P]'s are defined by the grammar: +<< + +P ::= +| Q +| Empty F +| Subset F F' +| Equal F F' + +Q ::= +| E.eq X X' +| In X F +| Q /\ Q' +| Q \/ Q' +| Q -> Q' +| Q <-> Q' +| ~ Q +| True +| False + +F ::= +| S +| empty +| singleton X +| add X F +| remove X F +| union F F' +| inter F F' +| diff F F' + +X ::= x1 | ... | xm +S ::= s1 | ... | sn + +>> + +The tactic will also work on some goals that vary slightly from +the above form: +- The variables and hypotheses may be mixed in any order and may + have already been introduced into the context. Moreover, + there may be additional, unrelated hypotheses mixed in (these + will be ignored). +- A conjunction of hypotheses will be handled as easily as + separate hypotheses, i.e., [P1 /\ P2 -> P] can be solved iff + [P1 -> P2 -> P] can be solved. +- [fsetdec] should solve any goal if the MSet-related hypotheses + are contradictory. +- [fsetdec] will first perform any necessary zeta and beta + reductions and will invoke [subst] to eliminate any Coq + equalities between finite sets or their elements. +- If [E.eq] is convertible with Coq's equality, it will not + matter which one is used in the hypotheses or conclusion. +- The tactic can solve goals where the finite sets or set + elements are expressed by Coq terms that are more complicated + than variables. However, non-local definitions are not + expanded, and Coq equalities between non-variable terms are + not used. For example, this goal will be solved: +<< + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g (g x2)) -> + In x1 s1 -> + In (g (g x2)) (f s2) +>> + This one will not be solved: +<< + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g x2) -> + In x1 s1 -> + g x2 = g (g x2) -> + In (g (g x2)) (f s2) +>> +*) + + (** * Facts and Tactics for Propositional Logic + These lemmas and tactics are in a module so that they do + not affect the namespace if you import the enclosing + module [Decide]. *) + Module MSetLogicalFacts. + Require Export Decidable. + Require Export Setoid. + + (** ** Lemmas and Tactics About Decidable Propositions *) + + (** ** Propositional Equivalences Involving Negation + These are all written with the unfolded form of + negation, since I am not sure if setoid rewriting will + always perform conversion. *) + + (** ** Tactics for Negations *) + + Tactic Notation "fold" "any" "not" := + repeat ( + match goal with + | H: context [?P -> False] |- _ => + fold (~ P) in H + | |- context [?P -> False] => + fold (~ P) + end). + + (** [push not using db] will pushes all negations to the + leaves of propositions in the goal, using the lemmas in + [db] to assist in checking the decidability of the + propositions involved. If [using db] is omitted, then + [core] will be used. Additional versions are provided + to manipulate the hypotheses or the hypotheses and goal + together. + + XXX: This tactic and the similar subsequent ones should + have been defined using [autorewrite]. However, dealing + with multiples rewrite sites and side-conditions is + done more cleverly with the following explicit + analysis of goals. *) + + Ltac or_not_l_iff P Q tac := + (rewrite (or_not_l_iff_1 P Q) by tac) || + (rewrite (or_not_l_iff_2 P Q) by tac). + + Ltac or_not_r_iff P Q tac := + (rewrite (or_not_r_iff_1 P Q) by tac) || + (rewrite (or_not_r_iff_2 P Q) by tac). + + Ltac or_not_l_iff_in P Q H tac := + (rewrite (or_not_l_iff_1 P Q) in H by tac) || + (rewrite (or_not_l_iff_2 P Q) in H by tac). + + Ltac or_not_r_iff_in P Q H tac := + (rewrite (or_not_r_iff_1 P Q) in H by tac) || + (rewrite (or_not_r_iff_2 P Q) in H by tac). + + Tactic Notation "push" "not" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff; + repeat ( + match goal with + | |- context [True -> False] => rewrite not_true_iff + | |- context [False -> False] => rewrite not_false_iff + | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec + | |- context [(?P -> False) -> (?Q -> False)] => + rewrite (contrapositive P Q) by dec + | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec + | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec + | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec + | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q) + | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q) + | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec + end); + fold any not. + + Tactic Notation "push" "not" := + push not using core. + + Tactic Notation + "push" "not" "in" "*" "|-" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff in * |-; + repeat ( + match goal with + | H: context [True -> False] |- _ => rewrite not_true_iff in H + | H: context [False -> False] |- _ => rewrite not_false_iff in H + | H: context [(?P -> False) -> False] |- _ => + rewrite (not_not_iff P) in H by dec + | H: context [(?P -> False) -> (?Q -> False)] |- _ => + rewrite (contrapositive P Q) in H by dec + | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec + | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec + | H: context [(?P -> False) -> ?Q] |- _ => + rewrite (imp_not_l P Q) in H by dec + | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H + | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H + | H: context [(?P -> ?Q) -> False] |- _ => + rewrite (not_imp_iff P Q) in H by dec + end); + fold any not. + + Tactic Notation "push" "not" "in" "*" "|-" := + push not in * |- using core. + + Tactic Notation "push" "not" "in" "*" "using" ident(db) := + push not using db; push not in * |- using db. + Tactic Notation "push" "not" "in" "*" := + push not in * using core. + + (** A simple test case to see how this works. *) + Lemma test_push : forall P Q R : Prop, + decidable P -> + decidable Q -> + (~ True) -> + (~ False) -> + (~ ~ P) -> + (~ (P /\ Q) -> ~ R) -> + ((P /\ Q) \/ ~ R) -> + (~ (P /\ Q) \/ R) -> + (R \/ ~ (P /\ Q)) -> + (~ R \/ (P /\ Q)) -> + (~ P -> R) -> + (~ ((R -> P) \/ (Q -> R))) -> + (~ (P /\ R)) -> + (~ (P -> R)) -> + True. + Proof. + intros. push not in *. + (* note that ~(R->P) remains (since R isnt decidable) *) + tauto. + Qed. + + (** [pull not using db] will pull as many negations as + possible toward the top of the propositions in the goal, + using the lemmas in [db] to assist in checking the + decidability of the propositions involved. If [using + db] is omitted, then [core] will be used. Additional + versions are provided to manipulate the hypotheses or + the hypotheses and goal together. *) + + Tactic Notation "pull" "not" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff; + repeat ( + match goal with + | |- context [True -> False] => rewrite not_true_iff + | |- context [False -> False] => rewrite not_false_iff + | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec + | |- context [(?P -> False) -> (?Q -> False)] => + rewrite (contrapositive P Q) by dec + | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec + | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec + | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec + | |- context [(?P -> False) /\ (?Q -> False)] => + rewrite <- (not_or_iff P Q) + | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q) + | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec + | |- context [(?Q -> False) /\ ?P] => + rewrite <- (not_imp_rev_iff P Q) by dec + end); + fold any not. + + Tactic Notation "pull" "not" := + pull not using core. + + Tactic Notation + "pull" "not" "in" "*" "|-" "using" ident(db) := + let dec := solve_decidable using db in + unfold not, iff in * |-; + repeat ( + match goal with + | H: context [True -> False] |- _ => rewrite not_true_iff in H + | H: context [False -> False] |- _ => rewrite not_false_iff in H + | H: context [(?P -> False) -> False] |- _ => + rewrite (not_not_iff P) in H by dec + | H: context [(?P -> False) -> (?Q -> False)] |- _ => + rewrite (contrapositive P Q) in H by dec + | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec + | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec + | H: context [(?P -> False) -> ?Q] |- _ => + rewrite (imp_not_l P Q) in H by dec + | H: context [(?P -> False) /\ (?Q -> False)] |- _ => + rewrite <- (not_or_iff P Q) in H + | H: context [?P -> ?Q -> False] |- _ => + rewrite <- (not_and_iff P Q) in H + | H: context [?P /\ (?Q -> False)] |- _ => + rewrite <- (not_imp_iff P Q) in H by dec + | H: context [(?Q -> False) /\ ?P] |- _ => + rewrite <- (not_imp_rev_iff P Q) in H by dec + end); + fold any not. + + Tactic Notation "pull" "not" "in" "*" "|-" := + pull not in * |- using core. + + Tactic Notation "pull" "not" "in" "*" "using" ident(db) := + pull not using db; pull not in * |- using db. + Tactic Notation "pull" "not" "in" "*" := + pull not in * using core. + + (** A simple test case to see how this works. *) + Lemma test_pull : forall P Q R : Prop, + decidable P -> + decidable Q -> + (~ True) -> + (~ False) -> + (~ ~ P) -> + (~ (P /\ Q) -> ~ R) -> + ((P /\ Q) \/ ~ R) -> + (~ (P /\ Q) \/ R) -> + (R \/ ~ (P /\ Q)) -> + (~ R \/ (P /\ Q)) -> + (~ P -> R) -> + (~ (R -> P) /\ ~ (Q -> R)) -> + (~ P \/ ~ R) -> + (P /\ ~ R) -> + (~ R /\ P) -> + True. + Proof. + intros. pull not in *. tauto. + Qed. + + End MSetLogicalFacts. + Import MSetLogicalFacts. + + (** * Auxiliary Tactics + Again, these lemmas and tactics are in a module so that + they do not affect the namespace if you import the + enclosing module [Decide]. *) + Module MSetDecideAuxiliary. + + (** ** Generic Tactics + We begin by defining a few generic, useful tactics. *) + + (** [if t then t1 else t2] executes [t] and, if it does not + fail, then [t1] will be applied to all subgoals + produced. If [t] fails, then [t2] is executed. *) + Tactic Notation + "if" tactic(t) + "then" tactic(t1) + "else" tactic(t2) := + first [ t; first [ t1 | fail 2 ] | t2 ]. + + (** [prop P holds by t] succeeds (but does not modify the + goal or context) if the proposition [P] can be proved by + [t] in the current context. Otherwise, the tactic + fails. *) + Tactic Notation "prop" constr(P) "holds" "by" tactic(t) := + let H := fresh in + assert P as H by t; + clear H. + + (** This tactic acts just like [assert ... by ...] but will + fail if the context already contains the proposition. *) + Tactic Notation "assert" "new" constr(e) "by" tactic(t) := + match goal with + | H: e |- _ => fail 1 + | _ => assert e by t + end. + + (** [subst++] is similar to [subst] except that + - it never fails (as [subst] does on recursive + equations), + - it substitutes locally defined variable for their + definitions, + - it performs beta reductions everywhere, which may + arise after substituting a locally defined function + for its definition. + *) + Tactic Notation "subst" "++" := + repeat ( + match goal with + | x : _ |- _ => subst x + end); + cbv zeta beta in *. + + (** [decompose records] calls [decompose record H] on every + relevant hypothesis [H]. *) + Tactic Notation "decompose" "records" := + repeat ( + match goal with + | H: _ |- _ => progress (decompose record H); clear H + end). + + (** ** Discarding Irrelevant Hypotheses + We will want to clear the context of any + non-MSet-related hypotheses in order to increase the + speed of the tactic. To do this, we will need to be + able to decide which are relevant. We do this by making + a simple inductive definition classifying the + propositions of interest. *) + + Inductive MSet_elt_Prop : Prop -> Prop := + | eq_Prop : forall (S : Set) (x y : S), + MSet_elt_Prop (x = y) + | eq_elt_prop : forall x y, + MSet_elt_Prop (E.eq x y) + | In_elt_prop : forall x s, + MSet_elt_Prop (In x s) + | True_elt_prop : + MSet_elt_Prop True + | False_elt_prop : + MSet_elt_Prop False + | conj_elt_prop : forall P Q, + MSet_elt_Prop P -> + MSet_elt_Prop Q -> + MSet_elt_Prop (P /\ Q) + | disj_elt_prop : forall P Q, + MSet_elt_Prop P -> + MSet_elt_Prop Q -> + MSet_elt_Prop (P \/ Q) + | impl_elt_prop : forall P Q, + MSet_elt_Prop P -> + MSet_elt_Prop Q -> + MSet_elt_Prop (P -> Q) + | not_elt_prop : forall P, + MSet_elt_Prop P -> + MSet_elt_Prop (~ P). + + Inductive MSet_Prop : Prop -> Prop := + | elt_MSet_Prop : forall P, + MSet_elt_Prop P -> + MSet_Prop P + | Empty_MSet_Prop : forall s, + MSet_Prop (Empty s) + | Subset_MSet_Prop : forall s1 s2, + MSet_Prop (Subset s1 s2) + | Equal_MSet_Prop : forall s1 s2, + MSet_Prop (Equal s1 s2). + + (** Here is the tactic that will throw away hypotheses that + are not useful (for the intended scope of the [fsetdec] + tactic). *) + Hint Constructors MSet_elt_Prop MSet_Prop : MSet_Prop. + Ltac discard_nonMSet := + decompose records; + repeat ( + match goal with + | H : ?P |- _ => + if prop (MSet_Prop P) holds by + (auto 100 with MSet_Prop) + then fail + else clear H + end). + + (** ** Turning Set Operators into Propositional Connectives + The lemmas from [MSetFacts] will be used to break down + set operations into propositional formulas built over + the predicates [In] and [E.eq] applied only to + variables. We are going to use them with [autorewrite]. + *) + + Hint Rewrite + F.empty_iff F.singleton_iff F.add_iff F.remove_iff + F.union_iff F.inter_iff F.diff_iff + : set_simpl. + + (** ** Decidability of MSet Propositions *) + + (** [In] is decidable. *) + Lemma dec_In : forall x s, + decidable (In x s). + Proof. + red; intros; generalize (F.mem_iff s x); case (mem x s); intuition. + Qed. + + (** [E.eq] is decidable. *) + Lemma dec_eq : forall (x y : E.t), + decidable (E.eq x y). + Proof. + red; intros x y; destruct (E.eq_dec x y); auto. + Qed. + + (** The hint database [MSet_decidability] will be given to + the [push_neg] tactic from the module [Negation]. *) + Hint Resolve dec_In dec_eq : MSet_decidability. + + (** ** Normalizing Propositions About Equality + We have to deal with the fact that [E.eq] may be + convertible with Coq's equality. Thus, we will find the + following tactics useful to replace one form with the + other everywhere. *) + + (** The next tactic, [Logic_eq_to_E_eq], mentions the term + [E.t]; thus, we must ensure that [E.t] is used in favor + of any other convertible but syntactically distinct + term. *) + Ltac change_to_E_t := + repeat ( + match goal with + | H : ?T |- _ => + progress (change T with E.t in H); + repeat ( + match goal with + | J : _ |- _ => progress (change T with E.t in J) + | |- _ => progress (change T with E.t) + end ) + | H : forall x : ?T, _ |- _ => + progress (change T with E.t in H); + repeat ( + match goal with + | J : _ |- _ => progress (change T with E.t in J) + | |- _ => progress (change T with E.t) + end ) + end). + + (** These two tactics take us from Coq's built-in equality + to [E.eq] (and vice versa) when possible. *) + + Ltac Logic_eq_to_E_eq := + repeat ( + match goal with + | H: _ |- _ => + progress (change (@Logic.eq E.t) with E.eq in H) + | |- _ => + progress (change (@Logic.eq E.t) with E.eq) + end). + + Ltac E_eq_to_Logic_eq := + repeat ( + match goal with + | H: _ |- _ => + progress (change E.eq with (@Logic.eq E.t) in H) + | |- _ => + progress (change E.eq with (@Logic.eq E.t)) + end). + + (** This tactic works like the built-in tactic [subst], but + at the level of set element equality (which may not be + the convertible with Coq's equality). *) + Ltac substMSet := + repeat ( + match goal with + | H: E.eq ?x ?y |- _ => rewrite H in *; clear H + end). + + (** ** Considering Decidability of Base Propositions + This tactic adds assertions about the decidability of + [E.eq] and [In] to the context. This is necessary for + the completeness of the [fsetdec] tactic. However, in + order to minimize the cost of proof search, we should be + careful to not add more than we need. Once negations + have been pushed to the leaves of the propositions, we + only need to worry about decidability for those base + propositions that appear in a negated form. *) + Ltac assert_decidability := + (** We actually don't want these rules to fire if the + syntactic context in the patterns below is trivially + empty, but we'll just do some clean-up at the + afterward. *) + repeat ( + match goal with + | H: context [~ E.eq ?x ?y] |- _ => + assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) + | H: context [~ In ?x ?s] |- _ => + assert new (In x s \/ ~ In x s) by (apply dec_In) + | |- context [~ E.eq ?x ?y] => + assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq) + | |- context [~ In ?x ?s] => + assert new (In x s \/ ~ In x s) by (apply dec_In) + end); + (** Now we eliminate the useless facts we added (because + they would likely be very harmful to performance). *) + repeat ( + match goal with + | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H + end). + + (** ** Handling [Empty], [Subset], and [Equal] + This tactic instantiates universally quantified + hypotheses (which arise from the unfolding of [Empty], + [Subset], and [Equal]) for each of the set element + expressions that is involved in some membership or + equality fact. Then it throws away those hypotheses, + which should no longer be needed. *) + Ltac inst_MSet_hypotheses := + repeat ( + match goal with + | H : forall a : E.t, _, + _ : context [ In ?x _ ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ In ?x _ ] => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _, + _ : context [ E.eq ?x _ ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ E.eq ?x _ ] => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _, + _ : context [ E.eq _ ?x ] |- _ => + let P := type of (H x) in + assert new P by (exact (H x)) + | H : forall a : E.t, _ + |- context [ E.eq _ ?x ] => + let P := type of (H x) in + assert new P by (exact (H x)) + end); + repeat ( + match goal with + | H : forall a : E.t, _ |- _ => + clear H + end). + + (** ** The Core [fsetdec] Auxiliary Tactics *) + + (** Here is the crux of the proof search. Recursion through + [intuition]! (This will terminate if I correctly + understand the behavior of [intuition].) *) + Ltac fsetdec_rec := + try (match goal with + | H: E.eq ?x ?x -> False |- _ => destruct H + end); + (reflexivity || + contradiction || + (progress substMSet; intuition fsetdec_rec)). + + (** If we add [unfold Empty, Subset, Equal in *; intros;] to + the beginning of this tactic, it will satisfy the same + specification as the [fsetdec] tactic; however, it will + be much slower than necessary without the pre-processing + done by the wrapper tactic [fsetdec]. *) + Ltac fsetdec_body := + inst_MSet_hypotheses; + autorewrite with set_simpl in *; + push not in * using MSet_decidability; + substMSet; + assert_decidability; + auto using (@Equivalence_Reflexive _ _ E.eq_equiv); + (intuition fsetdec_rec) || + fail 1 + "because the goal is beyond the scope of this tactic". + + End MSetDecideAuxiliary. + Import MSetDecideAuxiliary. + + (** * The [fsetdec] Tactic + Here is the top-level tactic (the only one intended for + clients of this library). It's specification is given at + the top of the file. *) + Ltac fsetdec := + (** We first unfold any occurrences of [iff]. *) + unfold iff in *; + (** We fold occurrences of [not] because it is better for + [intros] to leave us with a goal of [~ P] than a goal of + [False]. *) + fold any not; intros; + (** Now we decompose conjunctions, which will allow the + [discard_nonMSet] and [assert_decidability] tactics to + do a much better job. *) + decompose records; + discard_nonMSet; + (** We unfold these defined propositions on finite sets. If + our goal was one of them, then have one more item to + introduce now. *) + unfold Empty, Subset, Equal in *; intros; + (** We now want to get rid of all uses of [=] in favor of + [E.eq]. However, the best way to eliminate a [=] is in + the context is with [subst], so we will try that first. + In fact, we may as well convert uses of [E.eq] into [=] + when possible before we do [subst] so that we can even + more mileage out of it. Then we will convert all + remaining uses of [=] back to [E.eq] when possible. We + use [change_to_E_t] to ensure that we have a canonical + name for set elements, so that [Logic_eq_to_E_eq] will + work properly. *) + change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq; + (** The next optimization is to swap a negated goal with a + negated hypothesis when possible. Any swap will improve + performance by eliminating the total number of + negations, but we will get the maximum benefit if we + swap the goal with a hypotheses mentioning the same set + element, so we try that first. If we reach the fourth + branch below, we attempt any swap. However, to maintain + completeness of this tactic, we can only perform such a + swap with a decidable proposition; hence, we first test + whether the hypothesis is an [MSet_elt_Prop], noting + that any [MSet_elt_Prop] is decidable. *) + pull not using MSet_decidability; + unfold not in *; + match goal with + | H: (In ?x ?r) -> False |- (In ?x ?s) -> False => + contradict H; fsetdec_body + | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False => + contradict H; fsetdec_body + | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => + contradict H; fsetdec_body + | H: ?P -> False |- ?Q -> False => + if prop (MSet_elt_Prop P) holds by + (auto 100 with MSet_Prop) + then (contradict H; fsetdec_body) + else fsetdec_body + | |- _ => + fsetdec_body + end. + + (** * Examples *) + + Module MSetDecideTestCases. + + Lemma test_eq_trans_1 : forall x y z s, + E.eq x y -> + ~ ~ E.eq z y -> + In x s -> + In z s. + Proof. fsetdec. Qed. + + Lemma test_eq_trans_2 : forall x y z r s, + In x (singleton y) -> + ~ In z r -> + ~ ~ In z (add y r) -> + In x s -> + In z s. + Proof. fsetdec. Qed. + + Lemma test_eq_neq_trans_1 : forall w x y z s, + E.eq x w -> + ~ ~ E.eq x y -> + ~ E.eq y z -> + In w s -> + In w (remove z s). + Proof. fsetdec. Qed. + + Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s, + In x (singleton w) -> + ~ In x r1 -> + In x (add y r1) -> + In y r2 -> + In y (remove z r2) -> + In w s -> + In w (remove z s). + Proof. fsetdec. Qed. + + Lemma test_In_singleton : forall x, + In x (singleton x). + Proof. fsetdec. Qed. + + Lemma test_add_In : forall x y s, + In x (add y s) -> + ~ E.eq x y -> + In x s. + Proof. fsetdec. Qed. + + Lemma test_Subset_add_remove : forall x s, + s [<=] (add x (remove x s)). + Proof. fsetdec. Qed. + + Lemma test_eq_disjunction : forall w x y z, + In w (add x (add y (singleton z))) -> + E.eq w x \/ E.eq w y \/ E.eq w z. + Proof. fsetdec. Qed. + + Lemma test_not_In_disj : forall x y s1 s2 s3 s4, + ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> + ~ (In x s1 \/ In x s4 \/ E.eq y x). + Proof. fsetdec. Qed. + + Lemma test_not_In_conj : forall x y s1 s2 s3 s4, + ~ In x (union s1 (union s2 (union s3 (add y s4)))) -> + ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x. + Proof. fsetdec. Qed. + + Lemma test_iff_conj : forall a x s s', + (In a s' <-> E.eq x a \/ In a s) -> + (In a s' <-> In a (add x s)). + Proof. fsetdec. Qed. + + Lemma test_set_ops_1 : forall x q r s, + (singleton x) [<=] s -> + Empty (union q r) -> + Empty (inter (diff s q) (diff s r)) -> + ~ In x s. + Proof. fsetdec. Qed. + + Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4, + Empty s1 -> + In x2 (add x1 s1) -> + In x3 s2 -> + ~ In x3 (remove x2 s2) -> + ~ In x4 s3 -> + In x4 (add x3 s3) -> + In x1 s4 -> + Subset (add x4 s4) s4. + Proof. fsetdec. Qed. + + Lemma test_too_complex : forall x y z r s, + E.eq x y -> + (In x (singleton y) -> r [<=] s) -> + In z r -> + In z s. + Proof. + (** [fsetdec] is not intended to solve this directly. *) + intros until s; intros Heq H Hr; lapply H; fsetdec. + Qed. + + Lemma function_test_1 : + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g (g x2)) -> + In x1 s1 -> + In (g (g x2)) (f s2). + Proof. fsetdec. Qed. + + Lemma function_test_2 : + forall (f : t -> t), + forall (g : elt -> elt), + forall (s1 s2 : t), + forall (x1 x2 : elt), + Equal s1 (f s2) -> + E.eq x1 (g x2) -> + In x1 s1 -> + g x2 = g (g x2) -> + In (g (g x2)) (f s2). + Proof. + (** [fsetdec] is not intended to solve this directly. *) + intros until 3. intros g_eq. rewrite <- g_eq. fsetdec. + Qed. + + Lemma test_baydemir : + forall (f : t -> t), + forall (s : t), + forall (x y : elt), + In x (add y (f s)) -> + ~ E.eq x y -> + In x (f s). + Proof. + fsetdec. + Qed. + + End MSetDecideTestCases. + +End WDecideOn. + +Require Import MSetInterface. + +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [Decide] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WDecide]. *) + +Module WDecide (M:WSets) := WDecideOn M.E M. +Module Decide := WDecide. diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v new file mode 100644 index 0000000000..24eb77e627 --- /dev/null +++ b/theories/MSets/MSetEqProperties.v @@ -0,0 +1,937 @@ +(***********************************************************************) +(* 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$ *) + +(** * 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 MSetProperties Zerob Sumbool Omega DecidableTypeEx. + +Module WEqPropertiesOn (Import E:DecidableType)(M:WSetsOn E). +Module Import MP := WPropertiesOn E M. +Import FM Dec.F. +Import M. + +Definition Add := MP.Add. + +Section BasicProperties. + +(** Some old specifications written with boolean equalities. *) + +Variable s s' s'': t. +Variable x y z : elt. + +Lemma mem_eq: + E.eq x y -> mem x s=mem y s. +Proof. +intro H; rewrite H; auto. +Qed. + +Lemma equal_mem_1: + (forall a, mem a s=mem a s') -> equal s s'=true. +Proof. +intros; apply equal_1; unfold Equal; intros. +do 2 rewrite mem_iff; rewrite H; tauto. +Qed. + +Lemma equal_mem_2: + equal s s'=true -> forall a, mem a s=mem a s'. +Proof. +intros; rewrite (equal_2 H); auto. +Qed. + +Lemma subset_mem_1: + (forall a, mem a s=true->mem a s'=true) -> subset s s'=true. +Proof. +intros; apply subset_1; unfold Subset; intros a. +do 2 rewrite mem_iff; auto. +Qed. + +Lemma subset_mem_2: + subset s s'=true -> forall a, mem a s=true -> mem a s'=true. +Proof. +intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto. +Qed. + +Lemma empty_mem: mem x empty=false. +Proof. +rewrite <- not_mem_iff; auto with set. +Qed. + +Lemma is_empty_equal_empty: is_empty s = equal s empty. +Proof. +apply bool_1; split; intros. +auto with set. +rewrite <- is_empty_iff; auto with set. +Qed. + +Lemma choose_mem_1: choose s=Some x -> mem x s=true. +Proof. +auto with set. +Qed. + +Lemma choose_mem_2: choose s=None -> is_empty s=true. +Proof. +auto with set. +Qed. + +Lemma add_mem_1: mem x (add x s)=true. +Proof. +auto with set. +Qed. + +Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s. +Proof. +apply add_neq_b. +Qed. + +Lemma remove_mem_1: mem x (remove x s)=false. +Proof. +rewrite <- not_mem_iff; auto with set. +Qed. + +Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s. +Proof. +apply remove_neq_b. +Qed. + +Lemma singleton_equal_add: + equal (singleton x) (add x empty)=true. +Proof. +rewrite (singleton_equal_add x); auto with set. +Qed. + +Lemma union_mem: + mem x (union s s')=mem x s || mem x s'. +Proof. +apply union_b. +Qed. + +Lemma inter_mem: + mem x (inter s s')=mem x s && mem x s'. +Proof. +apply inter_b. +Qed. + +Lemma diff_mem: + mem x (diff s s')=mem x s && negb (mem x s'). +Proof. +apply diff_b. +Qed. + +(** properties of [mem] *) + +Lemma mem_3 : ~In x s -> mem x s=false. +Proof. +intros; rewrite <- not_mem_iff; auto. +Qed. + +Lemma mem_4 : mem x s=false -> ~In x s. +Proof. +intros; rewrite not_mem_iff; auto. +Qed. + +(** Properties of [equal] *) + +Lemma equal_refl: equal s s=true. +Proof. +auto with set. +Qed. + +Lemma equal_sym: equal s s'=equal s' s. +Proof. +intros; apply bool_1; do 2 rewrite <- equal_iff; intuition. +Qed. + +Lemma equal_trans: + equal s s'=true -> equal s' s''=true -> equal s s''=true. +Proof. +intros; rewrite (equal_2 H); auto. +Qed. + +Lemma equal_equal: + equal s s'=true -> equal s s''=equal s' s''. +Proof. +intros; rewrite (equal_2 H); auto. +Qed. + +Lemma equal_cardinal: + equal s s'=true -> cardinal s=cardinal s'. +Proof. +auto with set. +Qed. + +(* Properties of [subset] *) + +Lemma subset_refl: subset s s=true. +Proof. +auto with set. +Qed. + +Lemma subset_antisym: + subset s s'=true -> subset s' s=true -> equal s s'=true. +Proof. +auto with set. +Qed. + +Lemma subset_trans: + subset s s'=true -> subset s' s''=true -> subset s s''=true. +Proof. +do 3 rewrite <- subset_iff; intros. +apply subset_trans with s'; auto. +Qed. + +Lemma subset_equal: + equal s s'=true -> subset s s'=true. +Proof. +auto with set. +Qed. + +(** Properties of [choose] *) + +Lemma choose_mem_3: + is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}. +Proof. +intros. +generalize (@choose_1 s) (@choose_2 s). +destruct (choose s);intros. +exists e;auto with set. +generalize (H1 (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 with set. +Qed. + +Lemma add_equal: + mem x s=true -> equal (add x s) s=true. +Proof. +auto with set. +Qed. + +(** Properties of [remove] *) + +Lemma remove_mem_3: + mem y (remove x s)=true -> mem y s=true. +Proof. +rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto. +Qed. + +Lemma remove_equal: + mem x s=false -> equal (remove x s) s=true. +Proof. +intros; apply equal_1; apply remove_equal. +rewrite not_mem_iff; auto. +Qed. + +Lemma add_remove: + mem x s=true -> equal (add x (remove x s)) s=true. +Proof. +intros; apply equal_1; apply add_remove; auto with set. +Qed. + +Lemma remove_add: + mem x s=false -> equal (remove x (add x s)) s=true. +Proof. +intros; apply equal_1; apply remove_add; auto. +rewrite not_mem_iff; auto. +Qed. + +(** Properties of [is_empty] *) + +Lemma is_empty_cardinal: is_empty s = zerob (cardinal s). +Proof. +intros; apply bool_1; split; intros. +rewrite MP.cardinal_1; simpl; auto with set. +assert (cardinal s = 0) by (apply zerob_true_elim; auto). +auto with set. +Qed. + +(** Properties of [singleton] *) + +Lemma singleton_mem_1: mem x (singleton x)=true. +Proof. +auto with set. +Qed. + +Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false. +Proof. +intros; rewrite singleton_b. +unfold eqb; destruct (E.eq_dec x y); intuition. +Qed. + +Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y. +Proof. +intros; apply singleton_1; auto with set. +Qed. + +(** Properties of [union] *) + +Lemma union_sym: + equal (union s s') (union s' s)=true. +Proof. +auto with set. +Qed. + +Lemma union_subset_equal: + subset s s'=true -> equal (union s s') s'=true. +Proof. +auto with set. +Qed. + +Lemma union_equal_1: + equal s s'=true-> equal (union s s'') (union s' s'')=true. +Proof. +auto with set. +Qed. + +Lemma union_equal_2: + equal s' s''=true-> equal (union s s') (union s s'')=true. +Proof. +auto with set. +Qed. + +Lemma union_assoc: + equal (union (union s s') s'') (union s (union s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma add_union_singleton: + equal (add x s) (union (singleton x) s)=true. +Proof. +auto with set. +Qed. + +Lemma union_add: + equal (union (add x s) s') (add x (union s s'))=true. +Proof. +auto with set. +Qed. + +(* 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 with set. +Qed. + +(** Properties of [inter] *) + +Lemma inter_sym: equal (inter s s') (inter s' s)=true. +Proof. +auto with set. +Qed. + +Lemma inter_subset_equal: + subset s s'=true -> equal (inter s s') s=true. +Proof. +auto with set. +Qed. + +Lemma inter_equal_1: + equal s s'=true -> equal (inter s s'') (inter s' s'')=true. +Proof. +auto with set. +Qed. + +Lemma inter_equal_2: + equal s' s''=true -> equal (inter s s') (inter s s'')=true. +Proof. +auto with set. +Qed. + +Lemma inter_assoc: + equal (inter (inter s s') s'') (inter s (inter s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma union_inter_1: + equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma union_inter_2: + equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true. +Proof. +auto with set. +Qed. + +Lemma inter_add_1: mem x s'=true -> + equal (inter (add x s) s') (add x (inter s s'))=true. +Proof. +auto with set. +Qed. + +Lemma inter_add_2: mem x s'=false -> + equal (inter (add x s) s') (inter s s')=true. +Proof. +intros; apply equal_1; apply inter_add_2. +rewrite not_mem_iff; auto. +Qed. + +(* 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 with set. +Qed. + +(** Properties of [diff] *) + +Lemma diff_subset: subset (diff s s') s=true. +Proof. +auto with set. +Qed. + +Lemma diff_subset_equal: + subset s s'=true -> equal (diff s s') empty=true. +Proof. +auto with set. +Qed. + +Lemma remove_inter_singleton: + equal (remove x s) (diff s (singleton x))=true. +Proof. +auto with set. +Qed. + +Lemma diff_inter_empty: + equal (inter (diff s s') (inter s s')) empty=true. +Proof. +auto with set. +Qed. + +Lemma diff_inter_all: + equal (union (diff s s') (inter s s')) s=true. +Proof. +auto with set. +Qed. + +End BasicProperties. + +Hint Immediate empty_mem is_empty_equal_empty add_mem_1 + remove_mem_1 singleton_equal_add union_mem inter_mem + diff_mem equal_sym add_remove remove_add : set. +Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 + choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal + subset_refl subset_equal subset_antisym + add_mem_3 add_equal remove_mem_3 remove_equal : set. + + +(** General recursion principle *) + +Lemma set_rec: forall (P:t->Type), + (forall s s', equal s s'=true -> P s -> P s') -> + (forall s x, mem x s=false -> P s -> P (add x s)) -> + P empty -> forall s, P s. +Proof. +intros. +apply set_induction; auto; intros. +apply X with empty; auto with set. +apply X with (add x s0); auto with set. +apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto. +apply X0; auto with set; apply mem_3; auto. +Qed. + +(** Properties of [fold] *) + +Lemma exclusive_set : forall s s' x, + ~(In x s/\In x s') <-> mem x s && mem x s'=false. +Proof. +intros; do 2 rewrite mem_iff. +destruct (mem x s); destruct (mem x s'); intuition. +Qed. + +Section Fold. +Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). +Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f). +Variables (i:A). +Variables (s s':t)(x:elt). + +Lemma fold_empty: (fold f empty i) = i. +Proof. +apply fold_empty; auto. +Qed. + +Lemma fold_equal: + equal s s'=true -> eqA (fold f s i) (fold f s' i). +Proof. +intros; apply fold_equal with (eqA:=eqA); auto with set. +Qed. + +Lemma fold_add: + mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)). +Proof. +intros; apply fold_add with (eqA:=eqA); auto. +rewrite not_mem_iff; auto. +Qed. + +Lemma add_fold: + mem x s=true -> eqA (fold f (add x s) i) (fold f s i). +Proof. +intros; apply add_fold with (eqA:=eqA); auto with set. +Qed. + +Lemma remove_fold_1: + mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i). +Proof. +intros; apply remove_fold_1 with (eqA:=eqA); auto with set. +Qed. + +Lemma remove_fold_2: + mem x s=false -> eqA (fold f (remove x s) i) (fold f s i). +Proof. +intros; apply remove_fold_2 with (eqA:=eqA); auto. +rewrite not_mem_iff; auto. +Qed. + +Lemma fold_union: + (forall x, mem x s && mem x s'=false) -> + eqA (fold f (union s s') i) (fold f s (fold f s' i)). +Proof. +intros; apply fold_union with (eqA:=eqA); auto. +intros; rewrite exclusive_set; auto. +Qed. + +End Fold. + +(** Properties of [cardinal] *) + +Lemma add_cardinal_1: + forall s x, mem x s=true -> cardinal (add x s)=cardinal s. +Proof. +auto with set. +Qed. + +Lemma add_cardinal_2: + forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s). +Proof. +intros; apply add_cardinal_2; auto. +rewrite not_mem_iff; auto. +Qed. + +Lemma remove_cardinal_1: + forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s. +Proof. +intros; apply remove_cardinal_1; auto with set. +Qed. + +Lemma remove_cardinal_2: + forall s x, mem x s=false -> cardinal (remove x s)=cardinal s. +Proof. +intros; apply Equal_cardinal; apply equal_2; auto with set. +Qed. + +Lemma union_cardinal: + forall s s', (forall x, mem x s && mem x s'=false) -> + cardinal (union s s')=cardinal s+cardinal s'. +Proof. +intros; apply union_cardinal; auto; intros. +rewrite exclusive_set; auto. +Qed. + +Lemma subset_cardinal: + forall s s', subset s s'=true -> cardinal s<=cardinal s'. +Proof. +intros; apply subset_cardinal; auto with set. +Qed. + +Section Bool. + +(** Properties of [filter] *) + +Variable f:elt->bool. +Variable Comp: Proper (E.eq==>Logic.eq) f. + +Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)). +Proof. +repeat red; intros; f_equal; auto. +Qed. + +Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x. +Proof. +intros; apply filter_b; auto. +Qed. + +Lemma for_all_filter: + forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s). +Proof. +intros; apply bool_1; split; intros. +apply is_empty_1. +unfold Empty; intros. +rewrite filter_iff; auto. +red; destruct 1. +rewrite <- (@for_all_iff s f) in H; auto. +rewrite (H a H0) in H1; discriminate. +apply for_all_1; auto; red; intros. +revert H; rewrite <- is_empty_iff. +unfold Empty; intro H; generalize (H x); clear H. +rewrite filter_iff; auto. +destruct (f x); auto. +Qed. + +Lemma exists_filter : + forall s, exists_ f s=negb (is_empty (filter f s)). +Proof. +intros; apply bool_1; split; intros. +destruct (exists_2 Comp H) as (a,(Ha1,Ha2)). +apply bool_6. +red; intros; apply (@is_empty_2 _ H0 a); auto with set. +generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)). +destruct (choose (filter f s)). +intros H0 _; apply exists_1; auto. +exists e; generalize (H0 e); rewrite filter_iff; auto. +intros _ H0. +rewrite (is_empty_1 (H0 (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 with set. +Qed. + +Lemma partition_filter_2: + forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true. +Proof. +auto with set. +Qed. + +Lemma filter_add_1 : forall s x, f x = true -> + filter f (add x s) [=] add x (filter f s). +Proof. +red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff. +intuition. +rewrite <- H; apply Comp; auto. +Qed. + +Lemma filter_add_2 : forall s x, f x = false -> + filter f (add x s) [=] filter f s. +Proof. +red; intros; do 2 (rewrite filter_iff; auto); set_iff. +intuition. +assert (f x = f a) by (apply Comp; auto). +rewrite H in H1; rewrite H2 in H1; discriminate. +Qed. + +Lemma add_filter_1 : forall s s' x, + f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')). +Proof. +unfold Add, MP.Add; intros. +repeat rewrite filter_iff; auto. +rewrite H0; clear H0. +intuition. +setoid_replace y with x; auto. +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. +intuition. +setoid_replace x with a in H; auto. congruence. +Qed. + +Lemma union_filter: forall f g, + Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.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 (Proper (E.eq==>Logic.eq) (fun x => orb (f x) (g x))). + repeat red; intros. + rewrite (H x y H1); rewrite (H0 x y H1); auto. +unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto. +assert (f a || g a = true <-> f a = true \/ g a = true). + split; auto with bool. + intro H3; destruct (orb_prop _ _ H3); auto. +tauto. +Qed. + +Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s'). +Proof. +unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto. +Qed. + +(** Properties of [for_all] *) + +Lemma for_all_mem_1: forall s, + (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true. +Proof. +intros. +rewrite for_all_filter; auto. +rewrite is_empty_equal_empty. +apply equal_mem_1;intros. +rewrite filter_b; auto. +rewrite empty_mem. +generalize (H a); case (mem a s);intros;auto. +rewrite H0;auto. +Qed. + +Lemma for_all_mem_2: forall s, + (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true. +Proof. +intros. +rewrite for_all_filter in H; auto. +rewrite is_empty_equal_empty in H. +generalize (equal_mem_2 _ _ H x). +rewrite filter_b; auto. +rewrite empty_mem. +rewrite H0; simpl;intros. +rewrite <- negb_false_iff; auto. +Qed. + +Lemma for_all_mem_3: + forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false. +Proof. +intros. +apply (bool_eq_ind (for_all f s));intros;auto. +rewrite for_all_filter in H1; auto. +rewrite is_empty_equal_empty in H1. +generalize (equal_mem_2 _ _ H1 x). +rewrite filter_b; auto. +rewrite empty_mem. +rewrite H. +rewrite H0. +simpl;auto. +Qed. + +Lemma for_all_mem_4: + forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}. +Proof. +intros. +rewrite for_all_filter in H; auto. +destruct (choose_mem_3 _ H) as (x,(H0,H1));intros. +exists x. +rewrite filter_b in H1; auto. +elim (andb_prop _ _ H1). +split;auto. +rewrite <- negb_true_iff; auto. +Qed. + +(** Properties of [exists] *) + +Lemma for_all_exists: + forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s). +Proof. +intros. +rewrite for_all_b; auto. +rewrite exists_b; auto. +induction (elements s); simpl; auto. +destruct (f a); simpl; auto. +Qed. + +End Bool. +Section Bool'. + +Variable f:elt->bool. +Variable Comp: Proper (E.eq==>Logic.eq) f. + +Let Comp' : Proper (E.eq==>Logic.eq) (fun x => negb (f x)). +Proof. +repeat red; intros; f_equal; auto. +Qed. + +Lemma exists_mem_1: + forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false. +Proof. +intros. +rewrite for_all_exists; auto. +rewrite for_all_mem_1;auto with bool. +intros;generalize (H x H0);intros. +rewrite negb_true_iff; auto. +Qed. + +Lemma exists_mem_2: + forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false. +Proof. +intros. +rewrite for_all_exists in H; auto. +rewrite negb_false_iff in H. +rewrite <- negb_true_iff. +apply for_all_mem_2 with (2:=H); auto. +Qed. + +Lemma exists_mem_3: + forall s x, mem x s=true -> f x=true -> exists_ f s=true. +Proof. +intros. +rewrite for_all_exists; auto. +rewrite negb_true_iff. +apply for_all_mem_3 with x;auto. +rewrite negb_false_iff; auto. +Qed. + +Lemma exists_mem_4: + forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}. +Proof. +intros. +rewrite for_all_exists in H; auto. +rewrite negb_true_iff in H. +elim (@for_all_mem_4 (fun x =>negb (f x)) Comp' s);intros;auto. +elim p;intros. +exists x;split;auto. +rewrite <-negb_false_iff; auto. +Qed. + +End Bool'. + +Section Sum. + +(** Adding a valuation function on all elements of a set. *) + +Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0. +Notation compat_opL := (Proper (E.eq==>Logic.eq==>Logic.eq)). +Notation transposeL := (transpose Logic.eq). + +Lemma sum_plus : + forall f g, + Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> + forall s, sum (fun x =>f x+g x) s = sum f s + sum g s. +Proof. +unfold sum. +intros f g Hf Hg. +assert (fc : compat_opL (fun x:elt =>plus (f x))) by + (repeat red; intros; rewrite Hf; auto). +assert (ft : transposeL (fun x:elt =>plus (f x))) by (red; intros; omega). +assert (gc : compat_opL (fun x:elt => plus (g x))) by + (repeat red; intros; rewrite Hg; auto). +assert (gt : transposeL (fun x:elt =>plus (g x))) by (red; intros; omega). +assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))) by + (repeat red; intros; rewrite Hf,Hg; auto). +assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))) by (red; intros; omega). +intros s;pattern s; apply set_rec. +intros. +rewrite <- (fold_equal _ _ _ _ fc ft 0 _ _ H). +rewrite <- (fold_equal _ _ _ _ gc gt 0 _ _ H). +rewrite <- (fold_equal _ _ _ _ fgc fgt 0 _ _ H); auto. +intros; do 3 (rewrite (fold_add _ _ _);auto). +rewrite H0;simpl;omega. +do 3 rewrite fold_empty;auto. +Qed. + +Lemma sum_filter : forall f : elt -> bool, Proper (E.eq==>Logic.eq) f -> + forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)). +Proof. +unfold sum; intros f Hf. +assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). +assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))) by + (repeat red; intros; rewrite Hf; auto). +assert (ct : transposeL (fun x => plus (if f x then 1 else 0))) by + (red; intros; omega). +intros s;pattern s; apply set_rec. +intros. +change elt with E.t. +rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H). +apply equal_2 in H; rewrite <- H, <-H0; 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;auto. +rewrite MP.cardinal_1; auto. +unfold Empty; intros. +rewrite filter_iff; auto; set_iff; tauto. +Qed. + +Lemma fold_compat : + forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA) + (f g:elt->A->A), + Proper (E.eq==>eqA==>eqA) f -> transpose eqA f -> + Proper (E.eq==>eqA==>eqA) g -> transpose eqA g -> + forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) -> + (eqA (fold f s i) (fold g s i)). +Proof. +intros A eqA st f g fc ft gc gt i. +intro s; pattern s; apply set_rec; intros. +transitivity (fold f s0 i). +apply fold_equal with (eqA:=eqA); auto. +rewrite equal_sym; auto. +transitivity (fold g s0 i). +apply H0; intros; apply H1; auto with set. +elim (equal_2 H x); auto with set; intros. +apply fold_equal with (eqA:=eqA); auto with set. +transitivity (f x (fold f s0 i)). +apply fold_add with (eqA:=eqA); auto with set. +transitivity (g x (fold f s0 i)); auto with set. +transitivity (g x (fold g s0 i)); auto with set. +apply gc; auto with set. +symmetry; apply fold_add with (eqA:=eqA); auto. +do 2 rewrite fold_empty; reflexivity. +Qed. + +Lemma sum_compat : + forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> + forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. +intros. +unfold sum; apply (@fold_compat _ (@Logic.eq nat)); + repeat red; auto with *. +Qed. + +End Sum. + +End WEqPropertiesOn. + +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [EqProperties] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WEqProperties]. *) + +Module WEqProperties (M:WSets) := WEqPropertiesOn M.E M. +Module EqProperties := WEqProperties. diff --git a/theories/MSets/MSetFacts.v b/theories/MSets/MSetFacts.v new file mode 100644 index 0000000000..2ba9692174 --- /dev/null +++ b/theories/MSets/MSetFacts.v @@ -0,0 +1,527 @@ +(***********************************************************************) +(* 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$ *) + +(** * Finite sets library *) + +(** This functor derives additional facts from [MSetInterface.S]. These + facts are mainly the specifications of [MSetInterface.S] written using + different styles: equivalence and boolean equalities. + Moreover, we prove that [E.Eq] and [Equal] are setoid equalities. +*) + +Require Import DecidableTypeEx. +Require Export MSetInterface. +Set Implicit Arguments. +Unset Strict Implicit. + +(** First, a functor for Weak Sets in functorial version. *) + +Module WFactsOn (Import E : DecidableType)(Import M : WSetsOn E). + +Notation eq_dec := E.eq_dec. +Definition eqb x y := if eq_dec x y then true else false. + +(** * Specifications written using implications : + this used to be the default interface. *) + +Section ImplSpec. +Variable s s' : t. +Variable x y : elt. + +Lemma In_1 : E.eq x y -> In x s -> In y s. +Proof. intros E; rewrite E; auto. Qed. + +Lemma mem_1 : In x s -> mem x s = true. +Proof. intros; apply <- mem_spec; auto. Qed. +Lemma mem_2 : mem x s = true -> In x s. +Proof. intros; apply -> mem_spec; auto. Qed. + +Lemma equal_1 : Equal s s' -> equal s s' = true. +Proof. intros; apply <- equal_spec; auto. Qed. +Lemma equal_2 : equal s s' = true -> Equal s s'. +Proof. intros; apply -> equal_spec; auto. Qed. + +Lemma subset_1 : Subset s s' -> subset s s' = true. +Proof. intros; apply <- subset_spec; auto. Qed. +Lemma subset_2 : subset s s' = true -> Subset s s'. +Proof. intros; apply -> subset_spec; auto. Qed. + +Lemma is_empty_1 : Empty s -> is_empty s = true. +Proof. intros; apply <- is_empty_spec; auto. Qed. +Lemma is_empty_2 : is_empty s = true -> Empty s. +Proof. intros; apply -> is_empty_spec; auto. Qed. + +Lemma add_1 : E.eq x y -> In y (add x s). +Proof. intros; apply <- add_spec; auto. Qed. +Lemma add_2 : In y s -> In y (add x s). +Proof. intros; apply <- add_spec; auto. Qed. +Lemma add_3 : ~ E.eq x y -> In y (add x s) -> In y s. +Proof. rewrite add_spec. intros H [H'|H']; auto. elim H; auto. Qed. + +Lemma remove_1 : E.eq x y -> ~ In y (remove x s). +Proof. intros; rewrite remove_spec; intuition. Qed. +Lemma remove_2 : ~ E.eq x y -> In y s -> In y (remove x s). +Proof. intros; apply <- remove_spec; auto. Qed. +Lemma remove_3 : In y (remove x s) -> In y s. +Proof. rewrite remove_spec; intuition. Qed. + +Lemma singleton_1 : In y (singleton x) -> E.eq x y. +Proof. rewrite singleton_spec; auto. Qed. +Lemma singleton_2 : E.eq x y -> In y (singleton x). +Proof. rewrite singleton_spec; auto. Qed. + +Lemma union_1 : In x (union s s') -> In x s \/ In x s'. +Proof. rewrite union_spec; auto. Qed. +Lemma union_2 : In x s -> In x (union s s'). +Proof. rewrite union_spec; auto. Qed. +Lemma union_3 : In x s' -> In x (union s s'). +Proof. rewrite union_spec; auto. Qed. + +Lemma inter_1 : In x (inter s s') -> In x s. +Proof. rewrite inter_spec; intuition. Qed. +Lemma inter_2 : In x (inter s s') -> In x s'. +Proof. rewrite inter_spec; intuition. Qed. +Lemma inter_3 : In x s -> In x s' -> In x (inter s s'). +Proof. rewrite inter_spec; intuition. Qed. + +Lemma diff_1 : In x (diff s s') -> In x s. +Proof. rewrite diff_spec; intuition. Qed. +Lemma diff_2 : In x (diff s s') -> ~ In x s'. +Proof. rewrite diff_spec; intuition. Qed. +Lemma diff_3 : In x s -> ~ In x s' -> In x (diff s s'). +Proof. rewrite diff_spec; auto. Qed. + +Variable f : elt -> bool. +Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). + +Lemma filter_1 : compatb f -> In x (filter f s) -> In x s. +Proof. intros P; rewrite filter_spec; intuition. Qed. +Lemma filter_2 : compatb f -> In x (filter f s) -> f x = true. +Proof. intros P; rewrite filter_spec; intuition. Qed. +Lemma filter_3 : compatb f -> In x s -> f x = true -> In x (filter f s). +Proof. intros P; rewrite filter_spec; intuition. Qed. + +Lemma for_all_1 : compatb f -> + For_all (fun x => f x = true) s -> for_all f s = true. +Proof. intros; apply <- for_all_spec; auto. Qed. +Lemma for_all_2 : compatb f -> + for_all f s = true -> For_all (fun x => f x = true) s. +Proof. intros; apply -> for_all_spec; auto. Qed. + +Lemma exists_1 : compatb f -> + Exists (fun x => f x = true) s -> exists_ f s = true. +Proof. intros; apply <- exists_spec; auto. Qed. + +Lemma exists_2 : compatb f -> + exists_ f s = true -> Exists (fun x => f x = true) s. +Proof. intros; apply -> exists_spec; auto. Qed. + +Lemma elements_1 : In x s -> InA E.eq x (elements s). +Proof. intros; apply <- elements_spec1; auto. Qed. +Lemma elements_2 : InA E.eq x (elements s) -> In x s. +Proof. intros; apply -> elements_spec1; auto. Qed. + +End ImplSpec. + +Notation empty_1 := empty_spec (only parsing). +Notation fold_1 := fold_spec (only parsing). +Notation cardinal_1 := cardinal_spec (only parsing). +Notation partition_1 := partition_spec1 (only parsing). +Notation partition_2 := partition_spec2 (only parsing). +Notation choose_1 := choose_spec1 (only parsing). +Notation choose_2 := choose_spec2 (only parsing). +Notation elements_3w := elements_spec2w (only parsing). + +Hint Resolve mem_1 equal_1 subset_1 empty_1 + is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 + remove_2 singleton_2 union_1 union_2 union_3 + inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 + partition_1 partition_2 elements_1 elements_3w + : set. +Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 + remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 + filter_1 filter_2 for_all_2 exists_2 elements_2 + : set. + + +(** * Specifications written using equivalences : + this is now provided by the default interface. *) + +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. +intros E; rewrite E; intuition. +Qed. + +Lemma mem_iff : In x s <-> mem x s = true. +Proof. apply iff_sym, mem_spec. Qed. + +Lemma not_mem_iff : ~In x s <-> mem x s = false. +Proof. +rewrite <-mem_spec; destruct (mem x s); intuition. +Qed. + +Lemma equal_iff : s[=]s' <-> equal s s' = true. +Proof. apply iff_sym, equal_spec. Qed. + +Lemma subset_iff : s[<=]s' <-> subset s s' = true. +Proof. apply iff_sym, subset_spec. Qed. + +Lemma empty_iff : In x empty <-> False. +Proof. intuition; apply (empty_spec H). Qed. + +Lemma is_empty_iff : Empty s <-> is_empty s = true. +Proof. apply iff_sym, is_empty_spec. Qed. + +Lemma singleton_iff : In y (singleton x) <-> E.eq x y. +Proof. rewrite singleton_spec; intuition. Qed. + +Lemma add_iff : In y (add x s) <-> E.eq x y \/ In y s. +Proof. rewrite add_spec; intuition. Qed. + +Lemma add_neq_iff : ~ E.eq x y -> (In y (add x s) <-> In y s). +Proof. rewrite add_spec; intuition. elim H; auto. Qed. + +Lemma remove_iff : In y (remove x s) <-> In y s /\ ~E.eq x y. +Proof. rewrite remove_spec; intuition. Qed. + +Lemma remove_neq_iff : ~ E.eq x y -> (In y (remove x s) <-> In y s). +Proof. rewrite remove_spec; intuition. Qed. + +Variable f : elt -> bool. + +Lemma for_all_iff : Proper (E.eq==>Logic.eq) f -> + (For_all (fun x => f x = true) s <-> for_all f s = true). +Proof. intros; apply iff_sym, for_all_spec; auto. Qed. + +Lemma exists_iff : Proper (E.eq==>Logic.eq) f -> + (Exists (fun x => f x = true) s <-> exists_ f s = true). +Proof. intros; apply iff_sym, exists_spec; auto. Qed. + +Lemma elements_iff : In x s <-> InA E.eq x (elements s). +Proof. apply iff_sym, elements_spec1. Qed. + +End IffSpec. + +Notation union_iff := union_spec (only parsing). +Notation inter_iff := inter_spec (only parsing). +Notation diff_iff := diff_spec (only parsing). +Notation filter_iff := filter_spec (only parsing). + +(** Useful tactic for simplifying expressions like [In y (add x (union s s'))] *) + +Ltac set_iff := + repeat (progress ( + rewrite add_iff || rewrite remove_iff || rewrite singleton_iff + || rewrite union_iff || rewrite inter_iff || rewrite diff_iff + || rewrite empty_iff)). + +(** * Specifications written using boolean predicates *) + +Section BoolSpec. +Variable s s' s'' : t. +Variable x y z : elt. + +Lemma mem_b : E.eq x y -> mem x s = mem y s. +Proof. +intros. +generalize (mem_iff s x) (mem_iff s y)(In_eq_iff s H). +destruct (mem x s); destruct (mem y s); intuition. +Qed. + +Lemma empty_b : mem y empty = false. +Proof. +generalize (empty_iff y)(mem_iff empty y). +destruct (mem y empty); intuition. +Qed. + +Lemma add_b : mem y (add x s) = eqb x y || mem y s. +Proof. +generalize (mem_iff (add x s) y)(mem_iff s y)(add_iff s x y); unfold eqb. +destruct (eq_dec x y); destruct (mem y s); destruct (mem y (add x s)); intuition. +Qed. + +Lemma add_neq_b : ~ E.eq x y -> mem y (add x s) = mem y s. +Proof. +intros; generalize (mem_iff (add x s) y)(mem_iff s y)(add_neq_iff s H). +destruct (mem y s); destruct (mem y (add x s)); intuition. +Qed. + +Lemma remove_b : mem y (remove x s) = mem y s && negb (eqb x y). +Proof. +generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_iff s x y); unfold eqb. +destruct (eq_dec x y); destruct (mem y s); destruct (mem y (remove x s)); simpl; intuition. +Qed. + +Lemma remove_neq_b : ~ E.eq x y -> mem y (remove x s) = mem y s. +Proof. +intros; generalize (mem_iff (remove x s) y)(mem_iff s y)(remove_neq_iff s H). +destruct (mem y s); destruct (mem y (remove x s)); intuition. +Qed. + +Lemma singleton_b : mem y (singleton x) = eqb x y. +Proof. +generalize (mem_iff (singleton x) y)(singleton_iff x y); unfold eqb. +destruct (eq_dec x y); destruct (mem y (singleton x)); intuition. +Qed. + +Lemma union_b : mem x (union s s') = mem x s || mem x s'. +Proof. +generalize (mem_iff (union s s') x)(mem_iff s x)(mem_iff s' x)(union_iff s s' x). +destruct (mem x s); destruct (mem x s'); destruct (mem x (union s s')); intuition. +Qed. + +Lemma inter_b : mem x (inter s s') = mem x s && mem x s'. +Proof. +generalize (mem_iff (inter s s') x)(mem_iff s x)(mem_iff s' x)(inter_iff s s' x). +destruct (mem x s); destruct (mem x s'); destruct (mem x (inter s s')); intuition. +Qed. + +Lemma diff_b : mem x (diff s s') = mem x s && negb (mem x s'). +Proof. +generalize (mem_iff (diff s s') x)(mem_iff s x)(mem_iff s' x)(diff_iff s s' x). +destruct (mem x s); destruct (mem x s'); destruct (mem x (diff s s')); simpl; intuition. +Qed. + +Lemma elements_b : mem x s = existsb (eqb x) (elements s). +Proof. +generalize (mem_iff s x)(elements_iff s x)(existsb_exists (eqb x) (elements s)). +rewrite InA_alt. +destruct (mem x s); destruct (existsb (eqb x) (elements s)); auto; intros. +symmetry. +rewrite H1. +destruct H0 as (H0,_). +destruct H0 as (a,(Ha1,Ha2)); [ intuition |]. +exists a; intuition. +unfold eqb; destruct (eq_dec x a); auto. +rewrite <- H. +rewrite H0. +destruct H1 as (H1,_). +destruct H1 as (a,(Ha1,Ha2)); [intuition|]. +exists a; intuition. +unfold eqb in *; destruct (eq_dec x a); auto; discriminate. +Qed. + +Variable f : elt->bool. + +Lemma filter_b : Proper (E.eq==>Logic.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 : Proper (E.eq==>Logic.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 : Proper (E.eq==>Logic.eq) f -> + exists_ f s = existsb f (elements s). +Proof. +intros. +generalize (existsb_exists f (elements s))(exists_iff s H)(elements_iff s). +unfold Exists. +destruct (existsb f (elements s)); destruct (exists_ f s); auto; intros. +rewrite <- H1; intros. +destruct H0 as (H0,_). +destruct H0 as (a,(Ha1,Ha2)); auto. +exists a; split; auto. +rewrite H2; rewrite InA_alt; eauto. +symmetry. +rewrite H0. +destruct H1 as (_,H1). +destruct H1 as (a,(Ha1,Ha2)); auto. +rewrite (H2 a) in Ha1. +rewrite (InA_alt E.eq a (elements s)) in Ha1. +destruct Ha1 as (b,(Hb1,Hb2)). +exists b; auto. +rewrite <- (H _ _ Hb1); auto. +Qed. + +End BoolSpec. + +(** * Declarations of morphisms with respects to [E.eq] and [Equal] *) + +Instance In_m : Proper (E.eq==>Equal==>iff) In. +Proof. +unfold Equal; intros x y H s s' H0. +rewrite (In_eq_iff s H); auto. +Qed. + +Instance Empty_m : Proper (Equal==>iff) Empty. +Proof. +repeat red; unfold Empty; intros s s' E. +setoid_rewrite E; auto. +Qed. + +Instance is_empty_m : Proper (Equal==>Logic.eq) is_empty. +Proof. +intros s s' H. +generalize (is_empty_iff s). rewrite H at 1. rewrite is_empty_iff. +destruct (is_empty s); destruct (is_empty s'); intuition. +Qed. + +Instance mem_m : Proper (E.eq==>Equal==>Logic.eq) mem. +Proof. +intros x x' Hx s s' Hs. +generalize (mem_iff s x). rewrite Hs, Hx at 1; rewrite mem_iff. +destruct (mem x s); destruct (mem x' s'); intuition. +Qed. + +Instance singleton_m : Proper (E.eq==>Equal) singleton. +Proof. +intros x y H a. +rewrite !singleton_iff; split; intros; etransitivity; eauto. +Qed. + +Instance add_m : Proper (E.eq==>Equal==>Equal) add. +Proof. +intros x x' Hx s s' Hs a. rewrite !add_iff, Hx, Hs; intuition. +Qed. + +Instance remove_m : Proper (E.eq==>Equal==>Equal) remove. +Proof. +intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx, Hs; intuition. +Qed. + +Instance union_m : Proper (Equal==>Equal==>Equal) union. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition. +Qed. + +Instance inter_m : Proper (Equal==>Equal==>Equal) inter. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition. +Qed. + +Instance diff_m : Proper (Equal==>Equal==>Equal) diff. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition. +Qed. + +Instance Subset_m : Proper (Equal==>Equal==>iff) Subset. +Proof. +unfold Equal, Subset; firstorder. +Qed. + +Instance subset_m : Proper (Equal==>Equal==>Logic.eq) subset. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2. +generalize (subset_iff s1 s2). rewrite Hs1, Hs2 at 1. rewrite subset_iff. +destruct (subset s1 s2); destruct (subset s1' s2'); intuition. +Qed. + +Instance equal_m : Proper (Equal==>Equal==>Logic.eq) equal. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2. +generalize (equal_iff s1 s2). rewrite Hs1,Hs2 at 1. rewrite equal_iff. +destruct (equal s1 s2); destruct (equal s1' s2'); intuition. +Qed. + +Instance SubsetSetoid : PreOrder Subset. (* reflexive + transitive *) +Proof. firstorder. Qed. + +Definition Subset_refl := @PreOrder_Reflexive _ _ SubsetSetoid. +Definition Subset_trans := @PreOrder_Transitive _ _ SubsetSetoid. + +Instance In_s_m : Morphisms.Proper (E.eq ==> Subset ++> impl) In | 1. +Proof. + simpl_relation. eauto with set. +Qed. + +Instance Empty_s_m : Proper (Subset-->impl) Empty. +Proof. firstorder. Qed. + +Instance add_s_m : Proper (E.eq==>Subset++>Subset) add. +Proof. +intros x x' Hx s s' Hs a. rewrite !add_iff, Hx; intuition. +Qed. + +Instance remove_s_m : Proper (E.eq==>Subset++>Subset) remove. +Proof. +intros x x' Hx s s' Hs a. rewrite !remove_iff, Hx; intuition. +Qed. + +Instance union_s_m : Proper (Subset++>Subset++>Subset) union. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !union_iff, Hs1, Hs2; intuition. +Qed. + +Instance inter_s_m : Proper (Subset++>Subset++>Subset) inter. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !inter_iff, Hs1, Hs2; intuition. +Qed. + +Instance diff_s_m : Proper (Subset++>Subset-->Subset) diff. +Proof. +intros s1 s1' Hs1 s2 s2' Hs2 a. rewrite !diff_iff, Hs1, Hs2; intuition. +Qed. + + +(* [fold], [filter], [for_all], [exists_] and [partition] requires + some knowledge on [f] in order to be known as morphisms. *) + +Instance filter_equal `(Proper _ (E.eq==>Logic.eq) f) : + Proper (Equal==>Equal) (filter f). +Proof. +intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition. +Qed. + +Instance filter_subset `(Proper _ (E.eq==>Logic.eq) f) : + Proper (Subset==>Subset) (filter f). +Proof. +intros f Hf s s' Hs a. rewrite !filter_iff, Hs by auto; intuition. +Qed. + +Lemma filter_ext : forall f f', Proper (E.eq==>Logic.eq) f -> (forall x, f x = f' x) -> + forall s s', s[=]s' -> filter f s [=] filter f' s'. +Proof. +intros f f' Hf Hff' s s' Hss' x. rewrite 2 filter_iff; auto. +rewrite Hff', Hss'; intuition. +red; red; intros; rewrite <- 2 Hff'; auto. +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 WFactsOn. + +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [Facts] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WFacts]. *) + +Module WFacts (M:WSets) := WFactsOn M.E M. +Module Facts := WFacts. diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v new file mode 100644 index 0000000000..630da63028 --- /dev/null +++ b/theories/MSets/MSetInterface.v @@ -0,0 +1,944 @@ +(***********************************************************************) +(* 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$ *) + +(** * Finite set library *) + +(** Set interfaces, inspired by the one of Ocaml. When compared with + Ocaml, the main differences are: + - the lack of [iter] function, useless since Coq is purely functional + - the use of [option] types instead of [Not_found] exceptions + - the use of [nat] instead of [int] for the [cardinal] function + + Several variants of the set interfaces are available: + - [WSetsOn] : functorial signature for weak sets + - [WSets] : self-contained version of [WSets] + - [SetsOn] : functorial signature for ordered sets + - [Sets] : self-contained version of [Sets] + - [WRawSets] : a signature for weak sets that may be ill-formed + - [RawSets] : same for ordered sets + + If unsure, [S = Sets] is probably what you're looking for: most other + signatures are subsets of it, while [Sets] can be obtained from + [RawSets] via the use of a subset type (see (W)Raw2Sets below). +*) + +Require Export Bool OrderedType2 DecidableType2. +Set Implicit Arguments. +Unset Strict Implicit. + +Module Type WOps (E : DecidableType). + + Definition elt := E.t. + + Parameter t : Type. (** the abstract type of sets *) + + 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]. *) + + Parameter fold : forall A : Type, (elt -> A -> A) -> t -> A -> A. + (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], + where [x1 ... xN] are the elements of [s]. + The order in which elements of [s] are presented to [f] is + unspecified. *) + + Parameter for_all : (elt -> bool) -> t -> bool. + (** [for_all p s] checks if all elements of the set + satisfy the predicate [p]. *) + + Parameter exists_ : (elt -> bool) -> t -> bool. + (** [exists p s] checks if at least one element of + the set satisfies the predicate [p]. *) + + Parameter filter : (elt -> bool) -> t -> t. + (** [filter p s] returns the set of all elements in [s] + that satisfy predicate [p]. *) + + Parameter partition : (elt -> bool) -> t -> t * t. + (** [partition p s] returns a pair of sets [(s1, s2)], where + [s1] is the set of all the elements of [s] that satisfy the + predicate [p], and [s2] is the set of all the elements of + [s] that do not satisfy [p]. *) + + Parameter cardinal : t -> nat. + (** Return the number of elements of a set. *) + + Parameter elements : t -> list elt. + (** Return the list of all elements of the given set, in any order. *) + + Parameter choose : t -> option elt. + (** Return one element of the given set, or [None] if + the set is empty. Which element is chosen is unspecified. + Equal sets could return different elements. *) + +End WOps. + + + + +(** ** Functorial signature for weak sets + + Weak sets are sets without ordering on base elements, only + a decidable equality. *) + +Module Type WSetsOn (E : DecidableType). + (** First, we ask for all the functions *) + Include Type WOps E. + + (** Logical predicates *) + Parameter In : elt -> t -> Prop. + Instance In_compat : Proper (E.eq==>eq==>iff) In. + + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + + Definition eq : t -> t -> Prop := Equal. + Instance eq_equiv : Equivalence eq. (* obvious, for subtyping only *) + Parameter eq_dec : forall s s', { eq s s' } + { ~ eq s s' }. + + (** Specifications of set operators *) + + Section Spec. + Variable s s': t. + Variable x y : elt. + Variable f : elt -> bool. + Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). + + Parameter mem_spec : mem x s = true <-> In x s. + Parameter equal_spec : equal s s' = true <-> s[=]s'. + Parameter subset_spec : subset s s' = true <-> s[<=]s'. + Parameter empty_spec : Empty empty. + Parameter is_empty_spec : is_empty s = true <-> Empty s. + Parameter add_spec : In y (add x s) <-> E.eq y x \/ In y s. + Parameter remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. + Parameter singleton_spec : In y (singleton x) <-> E.eq y x. + Parameter union_spec : In x (union s s') <-> In x s \/ In x s'. + Parameter inter_spec : In x (inter s s') <-> In x s /\ In x s'. + Parameter diff_spec : In x (diff s s') <-> In x s /\ ~In x s'. + Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. + Parameter cardinal_spec : cardinal s = length (elements s). + Parameter filter_spec : compatb f -> + (In x (filter f s) <-> In x s /\ f x = true). + Parameter for_all_spec : compatb f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Parameter exists_spec : compatb f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Parameter partition_spec1 : compatb f -> + fst (partition f s) [=] filter f s. + Parameter partition_spec2 : compatb f -> + snd (partition f s) [=] filter (fun x => negb (f x)) s. + Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s. + (** When compared with ordered sets, here comes the only + property that is really weaker: *) + Parameter elements_spec2w : NoDupA E.eq (elements s). + Parameter choose_spec1 : choose s = Some x -> In x s. + Parameter choose_spec2 : choose s = None -> Empty s. + + End Spec. + +End WSetsOn. + +(** ** Static signature for weak sets + + Similar to the functorial signature [WSetsOn], except that the + module [E] of base elements is incorporated in the signature. *) + +Module Type WSets. + Declare Module E : DecidableType. + Include Type WSetsOn E. +End WSets. + +(** ** Functorial signature for sets on ordered elements + + Based on [WSetsOn], plus ordering on sets and [min_elt] and [max_elt] + and some stronger specifications for other functions. *) + +Module Type SetsOn (E : OrderedType). + Include Type WSetsOn E. + + Parameter compare : t -> t -> comparison. + (** Total ordering between sets. Can be used as the ordering function + for doing sets of sets. *) + + Parameter min_elt : t -> option elt. + (** Return the smallest element of the given set + (with respect to the [E.compare] ordering), + or [None] if the set is empty. *) + + Parameter max_elt : t -> option elt. + (** Same as [min_elt], but returns the largest element of the + given set. *) + + Parameter lt : t -> t -> Prop. + + (** Specification of [lt] *) + Instance lt_strorder : StrictOrder lt. + Instance lt_compat : Proper (eq==>eq==>iff) lt. + + Section Spec. + Variable s s': t. + Variable x y : elt. + + Parameter compare_spec : Cmp eq lt (compare s s') s s'. + + (** Additional specification of [elements] *) + Parameter elements_spec2 : sort E.lt (elements s). + + (** Remark: since [fold] is specified via [elements], this stronger + specification of [elements] has an indirect impact on [fold], + which can now be proved to receive elements in increasing order. + *) + + Parameter min_elt_spec1 : min_elt s = Some x -> In x s. + Parameter min_elt_spec2 : min_elt s = Some x -> In y s -> ~ E.lt y x. + Parameter min_elt_spec3 : min_elt s = None -> Empty s. + + Parameter max_elt_spec1 : max_elt s = Some x -> In x s. + Parameter max_elt_spec2 : max_elt s = Some x -> In y s -> ~ E.lt x y. + Parameter max_elt_spec3 : max_elt s = None -> Empty s. + + (** Additional specification of [choose] *) + Parameter choose_spec3 : choose s = Some x -> choose s' = Some y -> + Equal s s' -> E.eq x y. + + End Spec. + +End SetsOn. + + +(** ** Static signature for sets on ordered elements + + Similar to the functorial signature [SetsOn], except that the + module [E] of base elements is incorporated in the signature. *) + +Module Type Sets. + Declare Module E : OrderedType. + Include Type SetsOn E. +End Sets. + +Module Type S := Sets. + + +(** ** Some subtyping tests +<< +WSetsOn ---> WSets + | | + | | + V V +SetsOn ---> Sets + +Module S_WS (M : Sets) <: WSets := M. +Module Sfun_WSfun (E:OrderedType)(M : SetsOn E) <: WSetsOn E := M. +Module S_Sfun (M : Sets) <: SetsOn M.E := M. +Module WS_WSfun (M : WSets) <: WSetsOn M.E := M. +>> +*) + + + +(** ** Signatures for set representations with ill-formed values. + + Motivation: + + For many implementation of finite sets (AVL trees, sorted + lists, lists without duplicates), we use the same two-layer + approach: + + - A first module deals with the datatype (eg. list or tree) without + any restriction on the values we consider. In this module (named + "Raw" in the past), some results are stated under the assumption + that some invariant (e.g. sortedness) holds for the input sets. We + also prove that this invariant is preserved by set operators. + + - A second module implements the exact Sets interface by + using a subtype, for instance [{ l : list A | sorted l }]. + This module is a mere wrapper around the first Raw module. + + With the interfaces below, we give some respectability to + the "Raw" modules. This allows the interested users to directly + access them via the interfaces. Even better, we can build once + and for all a functor doing the transition between Raw and usual Sets. + + Description: + + The type [t] of sets may contain ill-formed values on which our + set operators may give wrong answers. In particular, [mem] + may not see a element in a ill-formed set (think for instance of a + unsorted list being given to an optimized [mem] that stops + its search as soon as a strictly larger element is encountered). + + Unlike optimized operators, the [In] predicate is supposed to + always be correct, even on ill-formed sets. Same for [Equal] and + other logical predicates. + + A predicate parameter [Ok] is used to discriminate between + well-formed and ill-formed values. Some lemmas hold only on sets + validating [Ok]. This predicate [Ok] is required to be + preserved by set operators. Moreover, a boolean function [isok] + should exist for identifying (at least some of) the well-formed sets. + +*) + + +Module Type WRawSets (E : DecidableType). + (** First, we ask for all the functions *) + Include Type WOps E. + + (** Is a set well-formed or ill-formed ? *) + + Parameter IsOk : t -> Prop. + Class Ok (s:t) : Prop := { ok : IsOk s }. + + (** In order to be able to validate (at least some) particular sets as + well-formed, we ask for a boolean function for (semi-)deciding + predicate [Ok]. If [Ok] isn't decidable, [isok] may be the + always-false function. *) + Parameter isok : t -> bool. + Instance isok_Ok `(isok s = true) : Ok s | 10. + + (** Logical predicates *) + Parameter In : elt -> t -> Prop. + Instance In_compat : Proper (E.eq==>eq==>iff) In. + + Definition Equal s s' := forall a : elt, In a s <-> In a s'. + Definition Subset s s' := forall a : elt, In a s -> In a s'. + Definition Empty s := forall a : elt, ~ In a s. + Definition For_all (P : elt -> Prop) s := forall x, In x s -> P x. + Definition Exists (P : elt -> Prop) s := exists x, In x s /\ P x. + + Notation "s [=] t" := (Equal s t) (at level 70, no associativity). + Notation "s [<=] t" := (Subset s t) (at level 70, no associativity). + + Definition eq : t -> t -> Prop := Equal. + Instance eq_equiv : Equivalence eq. + + (** First, all operations are compatible with the well-formed predicate. *) + + Instance empty_ok : Ok empty. + Instance add_ok s x `(Ok s) : Ok (add x s). + Instance remove_ok s x `(Ok s) : Ok (remove x s). + Instance singleton_ok x : Ok (singleton x). + Instance union_ok s s' `(Ok s, Ok s') : Ok (union s s'). + Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s'). + Instance diff_ok s s' `(Ok s, Ok s') : Ok (diff s s'). + Instance filter_ok s f `(Ok s) : Ok (filter f s). + Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)). + Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)). + + (** Now, the specifications, with constraints on the input sets. *) + + Section Spec. + Variable s s': t. + Variable x y : elt. + Variable f : elt -> bool. + Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). + + Parameter mem_spec : forall `{Ok s}, mem x s = true <-> In x s. + Parameter equal_spec : forall `{Ok s, Ok s'}, + equal s s' = true <-> s[=]s'. + Parameter subset_spec : forall `{Ok s, Ok s'}, + subset s s' = true <-> s[<=]s'. + Parameter empty_spec : Empty empty. + Parameter is_empty_spec : is_empty s = true <-> Empty s. + Parameter add_spec : forall `{Ok s}, + In y (add x s) <-> E.eq y x \/ In y s. + Parameter remove_spec : forall `{Ok s}, + In y (remove x s) <-> In y s /\ ~E.eq y x. + Parameter singleton_spec : In y (singleton x) <-> E.eq y x. + Parameter union_spec : forall `{Ok s, Ok s'}, + In x (union s s') <-> In x s \/ In x s'. + Parameter inter_spec : forall `{Ok s, Ok s'}, + In x (inter s s') <-> In x s /\ In x s'. + Parameter diff_spec : forall `{Ok s, Ok s'}, + In x (diff s s') <-> In x s /\ ~In x s'. + Parameter fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. + Parameter cardinal_spec : forall `{Ok s}, + cardinal s = length (elements s). + Parameter filter_spec : compatb f -> + (In x (filter f s) <-> In x s /\ f x = true). + Parameter for_all_spec : compatb f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Parameter exists_spec : compatb f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Parameter partition_spec1 : compatb f -> + fst (partition f s) [=] filter f s. + Parameter partition_spec2 : compatb f -> + snd (partition f s) [=] filter (fun x => negb (f x)) s. + Parameter elements_spec1 : InA E.eq x (elements s) <-> In x s. + Parameter elements_spec2w : forall `{Ok s}, NoDupA E.eq (elements s). + Parameter choose_spec1 : choose s = Some x -> In x s. + Parameter choose_spec2 : choose s = None -> Empty s. + + End Spec. + +(* + BUG ?! When the Instance *_ok were under a section, + this re-export was mandatory !! BUG in Global Instance ? + Hint Resolve empty_ok add_ok remove_ok union_ok inter_ok + diff_ok singleton_ok filter_ok partition_ok1 partition_ok2 + : typeclass_instances. +*) + +End WRawSets. + +(** From weak raw sets to weak usual sets *) + +Module WRaw2Sets (E:DecidableType)(M:WRawSets E) <: WSets with Module E := E. + + Module E := E. + Definition elt := E.t. + + Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. + Definition t := t_. + Implicit Arguments Mkt [ [is_ok] ]. + Hint Resolve is_ok : typeclass_instances. + + Definition In x s := M.In 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 mem x (s : t) := M.mem x s. + Definition add x (s : t) := Mkt (M.add x s). + Definition remove x (s : t) := Mkt (M.remove x s). + Definition singleton x := Mkt (M.singleton x). + Definition union (s s' : t) := Mkt (M.union s s'). + Definition inter (s s' : t) := Mkt (M.inter s s'). + Definition diff (s s' : t) := Mkt (M.diff s s'). + Definition equal (s s' : t) := M.equal s s'. + Definition subset (s s' : t) := M.subset s s'. + Definition empty := Mkt M.empty. + Definition is_empty (s : t) := M.is_empty s. + Definition elements (s : t) := M.elements s. + Definition choose (s : t) := M.choose s. + Definition fold (A : Type) f (s : t) : A -> A := M.fold f s. + Definition cardinal (s : t) := M.cardinal s. + Definition filter f (s : t) := Mkt (M.filter f s). + Definition for_all f (s : t) := M.for_all f s. + Definition exists_ f (s : t) := M.exists_ f s. + Definition partition f (s : t) := + let p := M.partition f s in (Mkt (fst p), Mkt (snd p)). + + Instance In_compat : Proper (E.eq==>eq==>iff) In. + Proof. repeat red. intros; apply M.In_compat; congruence. Qed. + + Definition eq : t -> t -> Prop := Equal. + + Instance eq_equiv : Equivalence eq. + Proof. firstorder. Qed. + + Definition eq_dec : forall (s s':t), { eq s s' }+{ ~eq s s' }. + Proof. + intros (s,Hs) (s',Hs'). + change ({M.Equal s s'}+{~M.Equal s s'}). + destruct (M.equal s s') as [ ]_eqn:H; [left|right]; + rewrite <- M.equal_spec; congruence. + Defined. + + + Section Spec. + Variable s s' : t. + Variable x y : elt. + Variable f : elt -> bool. + Notation compatb := (Proper (E.eq==>Logic.eq)) (only parsing). + + Lemma mem_spec : mem x s = true <-> In x s. + Proof. exact (@M.mem_spec _ _ _). Qed. + Lemma equal_spec : equal s s' = true <-> Equal s s'. + Proof. exact (@M.equal_spec _ _ _ _). Qed. + Lemma subset_spec : subset s s' = true <-> Subset s s'. + Proof. exact (@M.subset_spec _ _ _ _). Qed. + Lemma empty_spec : Empty empty. + Proof. exact M.empty_spec. Qed. + Lemma is_empty_spec : is_empty s = true <-> Empty s. + Proof. exact (@M.is_empty_spec _). Qed. + Lemma add_spec : In y (add x s) <-> E.eq y x \/ In y s. + Proof. exact (@M.add_spec _ _ _ _). Qed. + Lemma remove_spec : In y (remove x s) <-> In y s /\ ~E.eq y x. + Proof. exact (@M.remove_spec _ _ _ _). Qed. + Lemma singleton_spec : In y (singleton x) <-> E.eq y x. + Proof. exact (@M.singleton_spec _ _). Qed. + Lemma union_spec : In x (union s s') <-> In x s \/ In x s'. + Proof. exact (@M.union_spec _ _ _ _ _). Qed. + Lemma inter_spec : In x (inter s s') <-> In x s /\ In x s'. + Proof. exact (@M.inter_spec _ _ _ _ _). Qed. + Lemma diff_spec : In x (diff s s') <-> In x s /\ ~In x s'. + Proof. exact (@M.diff_spec _ _ _ _ _). Qed. + Lemma fold_spec : forall (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (fun a e => f e a) (elements s) i. + Proof. exact (@M.fold_spec _). Qed. + Lemma cardinal_spec : cardinal s = length (elements s). + Proof. exact (@M.cardinal_spec s _). Qed. + Lemma filter_spec : compatb f -> + (In x (filter f s) <-> In x s /\ f x = true). + Proof. exact (@M.filter_spec _ _ _). Qed. + Lemma for_all_spec : compatb f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. exact (@M.for_all_spec _ _). Qed. + Lemma exists_spec : compatb f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. exact (@M.exists_spec _ _). Qed. + Lemma partition_spec1 : compatb f -> Equal (fst (partition f s)) (filter f s). + Proof. exact (@M.partition_spec1 _ _). Qed. + Lemma partition_spec2 : compatb f -> + Equal (snd (partition f s)) (filter (fun x => negb (f x)) s). + Proof. exact (@M.partition_spec2 _ _). Qed. + Lemma elements_spec1 : InA E.eq x (elements s) <-> In x s. + Proof. exact (@M.elements_spec1 _ _). Qed. + Lemma elements_spec2w : NoDupA E.eq (elements s). + Proof. exact (@M.elements_spec2w _ _). Qed. + Lemma choose_spec1 : choose s = Some x -> In x s. + Proof. exact (@M.choose_spec1 _ _). Qed. + Lemma choose_spec2 : choose s = None -> Empty s. + Proof. exact (@M.choose_spec2 _). Qed. + + End Spec. + +End WRaw2Sets. + +(** Same approach for ordered sets *) + +Module Type RawSets (E : OrderedType). + Include Type WRawSets E. + + Parameter compare : t -> t -> comparison. + Parameter min_elt : t -> option elt. + Parameter max_elt : t -> option elt. + Parameter lt : t -> t -> Prop. + + (** Specification of [lt] *) + Instance lt_strorder : StrictOrder lt. + Instance lt_compat : Proper (eq==>eq==>iff) lt. + + Section Spec. + Variable s s': t. + Variable x y : elt. + + (** Specification of [compare] *) + Parameter compare_spec : forall `{Ok s, Ok s'}, Cmp eq lt (compare s s') s s'. + + (** Additional specification of [elements] *) + Parameter elements_spec2 : forall `{Ok s}, sort E.lt (elements s). + + (** Specification of [min_elt] *) + Parameter min_elt_spec1 : min_elt s = Some x -> In x s. + Parameter min_elt_spec2 : forall `{Ok s}, min_elt s = Some x -> In y s -> ~ E.lt y x. + Parameter min_elt_spec3 : min_elt s = None -> Empty s. + + (** Specification of [max_elt] *) + Parameter max_elt_spec1 : max_elt s = Some x -> In x s. + Parameter max_elt_spec2 : forall `{Ok s}, max_elt s = Some x -> In y s -> ~ E.lt x y. + Parameter max_elt_spec3 : max_elt s = None -> Empty s. + + (** Additional specification of [choose] *) + Parameter choose_spec3 : forall `{Ok s, Ok s'}, + choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. + + End Spec. + +End RawSets. + +(** From Raw to usual sets *) + +Module Raw2Sets (O:OrderedType)(M:RawSets O) <: S with Module E := O. + Include WRaw2Sets O M. + + Definition compare (s s':t) := M.compare s s'. + Definition min_elt (s:t) := M.min_elt s. + Definition max_elt (s:t) := M.max_elt s. + Definition lt (s s':t) := M.lt s s'. + + (** Specification of [lt] *) + Instance lt_strorder : StrictOrder lt. + Proof. + unfold lt; split; repeat red. + intros s; eapply StrictOrder_Irreflexive; eauto. + intros s s' s''; eapply StrictOrder_Transitive; eauto. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + repeat red. unfold eq, lt. + intros (s1,p1) (s2,p2) E (s1',p1') (s2',p2') E'; simpl. + change (M.eq s1 s2) in E. + change (M.eq s1' s2') in E'. + rewrite E,E'; intuition. + Qed. + + Section Spec. + Variable s s' s'' : t. + Variable x y : elt. + + Lemma compare_spec : Cmp eq lt (compare s s') s s'. + Proof. + generalize (@M.compare_spec s s' _ _). + unfold compare; destruct M.compare; auto. + Qed. + + (** Additional specification of [elements] *) + Lemma elements_spec2 : sort O.lt (elements s). + Proof. exact (@M.elements_spec2 _ _). Qed. + + (** Specification of [min_elt] *) + Lemma min_elt_spec1 : min_elt s = Some x -> In x s. + Proof. exact (@M.min_elt_spec1 _ _). Qed. + Lemma min_elt_spec2 : min_elt s = Some x -> In y s -> ~ O.lt y x. + Proof. exact (@M.min_elt_spec2 _ _ _ _). Qed. + Lemma min_elt_spec3 : min_elt s = None -> Empty s. + Proof. exact (@M.min_elt_spec3 _). Qed. + + (** Specification of [max_elt] *) + Lemma max_elt_spec1 : max_elt s = Some x -> In x s. + Proof. exact (@M.max_elt_spec1 _ _). Qed. + Lemma max_elt_spec2 : max_elt s = Some x -> In y s -> ~ O.lt x y. + Proof. exact (@M.max_elt_spec2 _ _ _ _). Qed. + Lemma max_elt_spec3 : max_elt s = None -> Empty s. + Proof. exact (@M.max_elt_spec3 _). Qed. + + (** Additional specification of [choose] *) + Lemma choose_spec3 : + choose s = Some x -> choose s' = Some y -> Equal s s' -> E.eq x y. + Proof. exact (@M.choose_spec3 _ _ _ _ _ _). Qed. + + End Spec. + +End Raw2Sets. + + +(** It is in fact possible to provide an ordering on sets with + very little information on them (more or less only the [In] + predicate). This generic build of ordering is in fact not + used for the moment, we rather use a simplier version + dedicated to sets-as-sorted-lists, see [MakeListOrdering]. +*) + +Module Type IN (O:OrderedType). + Parameter Inline t : Type. + Parameter Inline In : O.t -> t -> Prop. + Instance In_compat : Proper (O.eq==>eq==>iff) In. + Definition Equal s s' := forall x, In x s <-> In x s'. + Definition Empty s := forall x, ~In x s. +End IN. + +Module MakeSetOrdering (O:OrderedType)(Import M:IN O). + Module Import MO := OrderedTypeFacts O. + + Definition eq : t -> t -> Prop := Equal. + + Instance eq_equiv : Equivalence eq. + Proof. firstorder. Qed. + + Instance : Proper (O.eq==>eq==>iff) In. + Proof. + intros x x' Ex s s' Es. rewrite Ex. apply Es. + Qed. + + Definition Below x s := forall y, In y s -> O.lt y x. + Definition Above x s := forall y, In y s -> O.lt x y. + + Definition EquivBefore x s s' := + forall y, O.lt y x -> (In y s <-> In y s'). + + Definition EmptyBetween x y s := + forall z, In z s -> O.lt z y -> O.lt z x. + + Definition lt s s' := exists x, EquivBefore x s s' /\ + ((In x s' /\ Below x s) \/ + (In x s /\ exists y, In y s' /\ O.lt x y /\ EmptyBetween x y s')). + + Instance : Proper (O.eq==>eq==>eq==>iff) EquivBefore. + Proof. + unfold EquivBefore. intros x x' E s1 s1' E1 s2 s2' E2. + setoid_rewrite E; setoid_rewrite E1; setoid_rewrite E2; intuition. + Qed. + + Instance : Proper (O.eq==>eq==>iff) Below. + Proof. + unfold Below. intros x x' Ex s s' Es. + setoid_rewrite Ex; setoid_rewrite Es; intuition. + Qed. + + Instance : Proper (O.eq==>eq==>iff) Above. + Proof. + unfold Above. intros x x' Ex s s' Es. + setoid_rewrite Ex; setoid_rewrite Es; intuition. + Qed. + + Instance : Proper (O.eq==>O.eq==>eq==>iff) EmptyBetween. + Proof. + unfold EmptyBetween. intros x x' Ex y y' Ey s s' Es. + setoid_rewrite Ex; setoid_rewrite Ey; setoid_rewrite Es; intuition. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + unfold lt. intros s1 s1' E1 s2 s2' E2. + setoid_rewrite E1; setoid_rewrite E2; intuition. + Qed. + + Instance lt_strorder : StrictOrder lt. + Proof. + split. + (* irreflexive *) + intros s (x & _ & [(IN,Em)|(IN & y & IN' & LT & Be)]). + specialize (Em x IN); order. + specialize (Be x IN LT); order. + (* transitive *) + intros s1 s2 s3 (x & EQ & [(IN,Pre)|(IN,Lex)]) + (x' & EQ' & [(IN',Pre')|(IN',Lex')]). + (* 1) Pre / Pre --> Pre *) + assert (O.lt x x') by (specialize (Pre' x IN); auto). + exists x; split. + intros y Hy; rewrite <- (EQ' y); auto; order. + left; split; auto. + rewrite <- (EQ' x); auto. + (* 2) Pre / Lex *) + elim_compare x x'; intros Hxx'. + (* 2a) x=x' --> Pre *) + destruct Lex' as (y & INy & LT & Be). + exists y; split. + intros z Hz. split; intros INz. + specialize (Pre z INz). rewrite <- (EQ' z), <- (EQ z); auto; order. + specialize (Be z INz Hz). rewrite (EQ z), (EQ' z); auto; order. + left; split; auto. + intros z Hz. transitivity x; auto; order. + (* 2b) x<x' --> Pre *) + exists x; split. + intros z Hz. rewrite <- (EQ' z) by order; auto. + left; split; auto. + rewrite <- (EQ' x); auto. + (* 2c) x>x' --> Lex *) + exists x'; split. + intros z Hz. rewrite (EQ z) by order; auto. + right; split; auto. + rewrite (EQ x'); auto. + (* 3) Lex / Pre --> Lex *) + destruct Lex as (y & INy & LT & Be). + specialize (Pre' y INy). + exists x; split. + intros z Hz. rewrite <- (EQ' z) by order; auto. + right; split; auto. + exists y; repeat split; auto. + rewrite <- (EQ' y); auto. + intros z Hz LTz; apply Be; auto. rewrite (EQ' z); auto; order. + (* 4) Lex / Lex *) + elim_compare x x'; intros Hxx'. + (* 4a) x=x' --> impossible *) + destruct Lex as (y & INy & LT & Be). + rewrite Hxx' in LT; specialize (Be x' IN' LT); order. + (* 4b) x<x' --> Lex *) + exists x; split. + intros z Hz. rewrite <- (EQ' z) by order; auto. + right; split; auto. + destruct Lex as (y & INy & LT & Be). + elim_compare y x'; intros Hyx'. + (* 4ba *) + destruct Lex' as (y' & Iny' & LT' & Be'). + exists y'; repeat split; auto. order. + intros z Hz LTz. specialize (Be' z Hz LTz). + rewrite <- (EQ' z) in Hz by order. + apply Be; auto. order. + (* 4bb *) + exists y; repeat split; auto. + rewrite <- (EQ' y); auto. + intros z Hz LTz. apply Be; auto. rewrite (EQ' z); auto; order. + (* 4bc*) + specialize (Be x' IN' Hyx'); order. + (* 4c) x>x' --> Lex *) + exists x'; split. + intros z Hz. rewrite (EQ z) by order; auto. + right; split; auto. + rewrite (EQ x'); auto. + Qed. + + Lemma lt_empty_r : forall s s', Empty s' -> ~ lt s s'. + Proof. + intros s s' Hs' (x & _ & [(IN,_)|(_ & y & IN & _)]). + elim (Hs' x IN). + elim (Hs' y IN). + Qed. + + Definition Add x s s' := forall y, In y s' <-> O.eq x y \/ In y s. + + Lemma lt_empty_l : forall x s1 s2 s2', + Empty s1 -> Above x s2 -> Add x s2 s2' -> lt s1 s2'. + Proof. + intros x s1 s2 s2' Em Ab Ad. + exists x; split. + intros y Hy; split; intros IN. + elim (Em y IN). + rewrite (Ad y) in IN; destruct IN as [EQ|IN]. order. + specialize (Ab y IN). order. + left; split. + rewrite (Ad x); auto. + intros y Hy. elim (Em y Hy). + Qed. + + Lemma lt_add_lt : forall x1 x2 s1 s1' s2 s2', + Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' -> + O.lt x1 x2 -> lt s1' s2'. + Proof. + intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 LT. + exists x1; split; [ | right; split]; auto. + intros y Hy. rewrite (Ad1 y), (Ad2 y). + split; intros [U|U]; try order. + specialize (Ab1 y U). order. + specialize (Ab2 y U). order. + rewrite (Ad1 x1); auto. + exists x2; repeat split; auto. + rewrite (Ad2 x2); auto. + intros y. rewrite (Ad2 y). intros [U|U]. order. + specialize (Ab2 y U). order. + Qed. + + Lemma lt_add_eq : forall x1 x2 s1 s1' s2 s2', + Above x1 s1 -> Above x2 s2 -> Add x1 s1 s1' -> Add x2 s2 s2' -> + O.eq x1 x2 -> lt s1 s2 -> lt s1' s2'. + Proof. + intros x1 x2 s1 s1' s2 s2' Ab1 Ab2 Ad1 Ad2 Hx (x & EQ & Disj). + assert (O.lt x1 x). + destruct Disj as [(IN,_)|(IN,_)]; auto. rewrite Hx; auto. + exists x; split. + intros z Hz. rewrite (Ad1 z), (Ad2 z). + split; intros [U|U]; try order. + right; rewrite <- (EQ z); auto. + right; rewrite (EQ z); auto. + destruct Disj as [(IN,Em)|(IN & y & INy & LTy & Be)]. + left; split; auto. + rewrite (Ad2 x); auto. + intros z. rewrite (Ad1 z); intros [U|U]; try specialize (Ab1 z U); order. + right; split; auto. + rewrite (Ad1 x); auto. + exists y; repeat split; auto. + rewrite (Ad2 y); auto. + intros z. rewrite (Ad2 z). intros [U|U]; try specialize (Ab2 z U); order. + Qed. + +End MakeSetOrdering. + + +Module MakeListOrdering (O:OrderedType). + Module MO:=OrderedTypeFacts O. + + Notation t := (list O.t). + Notation In := (InA O.eq). + + Definition eq s s' := forall x, In x s <-> In x s'. + + Instance eq_equiv : Equivalence eq. + + Inductive lt_list : t -> t -> Prop := + | lt_nil : forall x s, lt_list nil (x :: s) + | lt_cons_lt : forall x y s s', + O.lt x y -> lt_list (x :: s) (y :: s') + | lt_cons_eq : forall x y s s', + O.eq x y -> lt_list s s' -> lt_list (x :: s) (y :: s'). + Hint Constructors lt_list. + + Definition lt := lt_list. + Hint Unfold lt. + + Instance lt_strorder : StrictOrder lt. + Proof. + split. + (* irreflexive *) + assert (forall s s', s=s' -> ~lt s s'). + red; induction 2. + discriminate. + inversion H; subst. + apply (StrictOrder_Irreflexive y); auto. + inversion H; subst; auto. + intros s Hs; exact (H s s (eq_refl s) Hs). + (* transitive *) + 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 2. transitivity x'; auto. + constructor 2. rewrite <- H0; auto. + intros. + inversion_clear H3. + constructor 2. rewrite H0; auto. + constructor 3; auto. transitivity y; auto. unfold lt in *; auto. + Qed. + + Instance lt_compat' : + Proper (eqlistA O.eq==>eqlistA O.eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + intros s1 s1' E1 s2 s2' E2 H. + revert s1' E1 s2' E2. + induction H; intros; inversion_clear E1; inversion_clear E2. + constructor 1. + constructor 2. MO.order. + constructor 3. MO.order. unfold lt in *; auto. + Qed. + + Lemma eq_cons : + forall l1 l2 x y, + O.eq x y -> eq l1 l2 -> eq (x :: l1) (y :: l2). + Proof. + unfold eq; intros l1 l2 x y Exy E12 z. + split; inversion_clear 1. + left; MO.order. right; rewrite <- E12; auto. + left; MO.order. right; rewrite E12; auto. + Qed. + Hint Resolve eq_cons. + + Lemma cons_Cmp : forall c x1 x2 l1 l2, O.eq x1 x2 -> + Cmp eq lt c l1 l2 -> Cmp eq lt c (x1::l1) (x2::l2). + Proof. + destruct c; simpl; unfold flip; auto. + Qed. + Hint Resolve cons_Cmp. + +End MakeListOrdering. diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v new file mode 100644 index 0000000000..2b7dbb586f --- /dev/null +++ b/theories/MSets/MSetList.v @@ -0,0 +1,866 @@ +(***********************************************************************) +(* 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$ *) + +(** * Finite sets library *) + +(** This file proposes an implementation of the non-dependant + interface [MSetInterface.S] using strictly ordered list. *) + +Require Export MSetInterface. +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 Ops (X:OrderedType) <: WOps X. + + Definition elt := X.t. + Definition t := list elt. + + Definition empty : t := nil. + + Definition is_empty (l : t) := if l then true else false. + + (** ** The set operations. *) + + Fixpoint mem x s := + 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 s := + 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) := x :: nil. + + Fixpoint remove x s := + 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' := + 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. + + Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B := + fold_left (flip f) s i. + + Fixpoint filter (f : elt -> bool) (s : t) : 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) : 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) : 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) : 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. + + Fixpoint compare s s' := + match s, s' with + | nil, nil => Eq + | nil, _ => Lt + | _, nil => Gt + | x::s, x'::s' => + match X.compare x x' with + | Eq => compare s s' + | Lt => Lt + | Gt => Gt + end + end. + +End Ops. + +Module MakeRaw (X: OrderedType) <: RawSets X. + Module Import MX := OrderedTypeFacts X. + + Include Ops X. + + (** ** Proofs of set operation specifications. *) + + Section ForNotations. + + Notation Sort := (sort X.lt). + Notation Inf := (lelistA X.lt). + Notation In := (InA X.eq). + + Definition IsOk := Sort. + + Class Ok (s:t) : Prop := { ok : Sort s }. + + Hint Resolve @ok. + Hint Constructors Ok. + + Instance Sort_Ok `(Hs : Sort s) : Ok s := Hs. + + Ltac inv_ok := match goal with + | H:Ok (_ :: _) |- _ => apply @ok in H; inversion_clear H; inv_ok + | H:Ok nil |- _ => clear H; inv_ok + | H:Sort ?l |- _ => generalize (Build_Ok H); clear H; intro H; inv_ok + | _ => idtac + end. + + Ltac inv := invlist InA; inv_ok; invlist lelistA. + Ltac constructors := repeat constructor. + + Ltac sort_inf_in := match goal with + | H:Inf ?x ?l, H':In ?y ?l |- _ => + cut (X.lt x y); [ intro | apply Sort_Inf_In with l; auto] + | _ => fail + end. + + Definition inf x l := + match l with + | nil => true + | y::_ => match X.compare x y with Lt => true | _ => false end + end. + + Fixpoint isok l := + match l with + | nil => true + | x::l => inf x l && isok l + end. + + Lemma inf_iff : forall x l, Inf x l <-> inf x l = true. + Proof. + induction l as [ | y l IH]. + simpl; split; auto. + simpl. + elim_compare x y; intuition; try discriminate. + inv; order. + inv; order. + Qed. + + Lemma isok_iff : forall l, Ok l <-> isok l = true. + Proof. + induction l as [ | x l IH]. + simpl; split; auto; constructor. + simpl. + rewrite andb_true_iff, <- inf_iff, <- IH. + split. + intros; inv; auto. + constructor; intuition. + Qed. + + Global Instance isok_Ok `(isok s = true) : Ok s | 10. + Proof. + intros. apply <- isok_iff. auto. + Qed. + + 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_spec : + forall (s : t) (x : elt) (Hs : Ok s), mem x s = true <-> In x s. + Proof. + induction s; intros; inv; simpl. + intuition. discriminate. inv. + elim_compare x a; intros; rewrite InA_cons; intuition; try order. + discriminate. + sort_inf_in. order. + rewrite <- IHs; auto. + rewrite IHs; 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. + intros; elim_compare x a; intros; inv; intuition. + Qed. + Hint Resolve add_inf. + + Global Instance add_ok s x `(Ok s) : Ok (add x s). + Proof. + simple induction s; simpl. + intuition. + intros; elim_compare x a; intros; inv; auto. + Qed. + + Lemma add_spec : + forall (s : t) (x y : elt) (Hs : Ok s), + In y (add x s) <-> X.eq y x \/ In y s. + Proof. + induction s; simpl; intros. + intuition. inv; auto. + elim_compare x a; intros; inv; rewrite !InA_cons, ?IHs; intuition. + left; order. + Qed. + + Lemma remove_inf : + forall (s : t) (x a : elt) (Hs : Ok s), Inf a s -> Inf a (remove x s). + Proof. + induction s; simpl. + intuition. + intros; elim_compare x a; intros; inv; auto. + apply Inf_lt with a; auto. + Qed. + Hint Resolve remove_inf. + + Global Instance remove_ok s x `(Ok s) : Ok (remove x s). + Proof. + induction s; simpl. + intuition. + intros; elim_compare x a; intros; inv; auto. + Qed. + + Lemma remove_spec : + forall (s : t) (x y : elt) (Hs : Ok s), + In y (remove x s) <-> In y s /\ ~X.eq y x. + Proof. + induction s; simpl; intros. + intuition; inv; auto. + elim_compare x a; intros; inv; rewrite !InA_cons, ?IHs; intuition; + try sort_inf_in; try order. + Qed. + + Global Instance singleton_ok x : Ok (singleton x). + Proof. + unfold singleton; simpl; auto. + Qed. + + Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x. + Proof. + unfold singleton; simpl; split; intros; inv; auto. + Qed. + + Ltac induction2 := + simple induction s; + [ simpl; auto; try solve [ intros; inv ] + | intros x l Hrec; simple induction s'; + [ simpl; auto; try solve [ intros; inv ] + | intros x' l' Hrec'; simpl; elim_compare x x'; intros; inv; auto ]]. + + Lemma union_inf : + forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'), + Inf a s -> Inf a s' -> Inf a (union s s'). + Proof. + induction2. + Qed. + Hint Resolve union_inf. + + Global Instance union_ok s s' `(Ok s, Ok s') : Ok (union s s'). + Proof. + induction2; constructors; try apply @ok; auto. + apply Inf_eq with x'; auto; apply union_inf; auto; apply Inf_eq with x; auto. + change (Inf x' (union (x :: l) l')); auto. + Qed. + + Lemma union_spec : + forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), + In x (union s s') <-> In x s \/ In x s'. + Proof. + induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto. + left; order. + Qed. + + Lemma inter_inf : + forall (s s' : t) (a : elt) (Hs : Ok s) (Hs' : Ok s'), + Inf a s -> Inf a s' -> Inf a (inter s s'). + Proof. + induction2. + apply Inf_lt with x; auto. + apply Hrec'; auto. + apply Inf_lt with x'; auto. + Qed. + Hint Resolve inter_inf. + + Global Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s'). + Proof. + induction2. + constructors; auto. + apply Inf_eq with x'; auto; apply inter_inf; auto; apply Inf_eq with x; auto. + Qed. + + Lemma inter_spec : + forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), + In x (inter s s') <-> In x s /\ In x s'. + Proof. + induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto; + try sort_inf_in; try order. + Qed. + + Lemma diff_inf : + forall (s s' : t) (Hs : Ok s) (Hs' : Ok s') (a : elt), + Inf a s -> Inf a s' -> Inf a (diff s s'). + Proof. + induction2. + apply Hrec; trivial. + apply Inf_lt with x; auto. + apply Inf_lt with x'; auto. + apply Hrec'; auto. + apply Inf_lt with x'; auto. + Qed. + Hint Resolve diff_inf. + + Global Instance diff_ok s s' `(Ok s, Ok s') : Ok (diff s s'). + Proof. + induction2. constructors; auto. apply @ok; auto. + Qed. + + Lemma diff_spec : + forall (s s' : t) (x : elt) (Hs : Ok s) (Hs' : Ok s'), + In x (diff s s') <-> In x s /\ ~In x s'. + Proof. + induction2; try rewrite ?InA_cons, ?Hrec, ?Hrec'; intuition; inv; auto; + try sort_inf_in; try order. + right; intuition; inv; order. + Qed. + + Lemma equal_spec : + forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'), + equal s s' = true <-> Equal s s'. + Proof. + induction s as [ | x s IH]; intros [ | x' s'] Hs Hs'; simpl. + intuition. + split; intros H. discriminate. assert (In x' nil) by (rewrite H; auto). inv. + split; intros H. discriminate. assert (In x nil) by (rewrite <-H; auto). inv. + inv. + elim_compare x x'; intros C; try discriminate. + (* x=x' *) + rewrite IH; auto. + split; intros E y; specialize (E y). + rewrite !InA_cons, E, C; intuition. + rewrite !InA_cons, C in E. intuition; try sort_inf_in; order. + (* x<x' *) + split; intros E. discriminate. + assert (In x (x'::s')) by (rewrite <- E; auto). + inv; try sort_inf_in; order. + (* x>x' *) + split; intros E. discriminate. + assert (In x' (x::s)) by (rewrite E; auto). + inv; try sort_inf_in; order. + Qed. + + Lemma subset_spec : + forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'), + subset s s' = true <-> Subset s s'. + Proof. + intros s s'; revert s. + induction s' as [ | x' s' IH]; intros [ | x s] Hs Hs'; simpl; auto. + split; try red; intros; auto. + split; intros H. discriminate. assert (In x nil) by (apply H; auto). inv. + split; try red; intros; auto. inv. + inv. elim_compare x x'; intros C. + (* x=x' *) + rewrite IH; auto. + split; intros S y; specialize (S y). + rewrite !InA_cons, C. intuition. + rewrite !InA_cons, C in S. intuition; try sort_inf_in; order. + (* x<x' *) + split; intros S. discriminate. + assert (In x (x'::s')) by (apply S; auto). + inv; try sort_inf_in; order. + (* x>x' *) + rewrite IH; auto. + split; intros S y; specialize (S y). + rewrite !InA_cons. intuition. + rewrite !InA_cons in S. rewrite !InA_cons. intuition; try sort_inf_in; order. + Qed. + + Global Instance empty_ok : Ok empty. + Proof. + constructors. + Qed. + + Lemma empty_spec : Empty empty. + Proof. + unfold Empty, empty; intuition; inv. + Qed. + + Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s. + Proof. + intros [ | x s]; simpl. + split; auto. intros _ x H. inv. + split. discriminate. intros H. elim (H x); auto. + Qed. + + Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s. + Proof. + intuition. + Qed. + + Lemma elements_spec2 : forall (s : t) (Hs : Ok s), Sort (elements s). + Proof. + auto. + Qed. + + Lemma elements_spec2w : forall (s : t) (Hs : Ok s), NoDupA X.eq (elements s). + Proof. + auto. + Qed. + + Lemma min_elt_spec1 : forall (s : t) (x : elt), min_elt s = Some x -> In x s. + Proof. + destruct s; simpl; inversion 1; auto. + Qed. + + Lemma min_elt_spec2 : + forall (s : t) (x y : elt) (Hs : Ok s), + min_elt s = Some x -> In y s -> ~ X.lt y x. + Proof. + induction s as [ | x s IH]; simpl; inversion 2; subst. + intros; inv; try sort_inf_in; order. + Qed. + + Lemma min_elt_spec3 : forall s : t, min_elt s = None -> Empty s. + Proof. + destruct s; simpl; red; intuition. inv. discriminate. + Qed. + + Lemma max_elt_spec1 : forall (s : t) (x : elt), max_elt s = Some x -> In x s. + Proof. + induction s as [ | x s IH]. inversion 1. + destruct s as [ | y s]. simpl. inversion 1; subst; auto. + right; apply IH; auto. + Qed. + + Lemma max_elt_spec2 : + forall (s : t) (x y : elt) (Hs : Ok s), + max_elt s = Some x -> In y s -> ~ X.lt x y. + Proof. + induction s as [ | a s IH]. inversion 2. + destruct s as [ | b s]. inversion 2; subst. intros; inv; order. + intros. inv; auto. + assert (~X.lt x b) by (apply IH; auto). + assert (X.lt a b) by auto. + order. + Qed. + + Lemma max_elt_spec3 : forall s : t, max_elt s = None -> Empty s. + Proof. + induction s as [ | a s IH]. red; intuition; inv. + destruct s as [ | b s]. inversion 1. + intros; elim IH with b; auto. + Qed. + + Definition choose_spec1 : + forall (s : t) (x : elt), choose s = Some x -> In x s := min_elt_spec1. + + Definition choose_spec2 : + forall s : t, choose s = None -> Empty s := min_elt_spec3. + + Lemma choose_spec3: forall s s' x x', Ok s -> Ok s' -> + choose s = Some x -> choose s' = Some x' -> Equal s s' -> X.eq x x'. + Proof. + unfold choose; intros s s' x x' Hs Hs' Hx Hx' H. + assert (~X.lt x x'). + apply min_elt_spec2 with s'; auto. + rewrite <-H; auto using min_elt_spec1. + assert (~X.lt x' x). + apply min_elt_spec2 with s; auto. + rewrite H; auto using min_elt_spec1. + order. + Qed. + + Lemma fold_spec : + forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. + Proof. + reflexivity. + Qed. + + Lemma cardinal_spec : + forall (s : t) (Hs : Ok s), + cardinal s = length (elements s). + Proof. + auto. + Qed. + + Lemma filter_inf : + forall (s : t) (x : elt) (f : elt -> bool) (Hs : Ok s), + Inf x s -> Inf x (filter f s). + Proof. + simple induction s; simpl. + intuition. + intros x l Hrec a f Hs Ha; inv. + case (f x); auto. + apply Hrec; auto. + apply Inf_lt with x; auto. + Qed. + + Global Instance filter_ok s f `(Ok s) : Ok (filter f s). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec f Hs; inv. + case (f x); auto. + constructors; auto. + apply filter_inf; auto. + Qed. + + Lemma filter_spec : + forall (s : t) (x : elt) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (In x (filter f s) <-> In x s /\ f x = true). + Proof. + induction s; simpl; intros. + split; intuition; inv. + destruct (f a) as [ ]_eqn:F; rewrite !InA_cons, ?IHs; intuition. + setoid_replace x with a; auto. + setoid_replace a with x in F; auto; congruence. + Qed. + + Lemma for_all_spec : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. + unfold For_all; induction s; simpl; intros. + split; intros; auto. inv. + destruct (f a) as [ ]_eqn:F. + rewrite IHs; auto. firstorder. inv; auto. + setoid_replace x with a; auto. + split; intros H'. discriminate. + rewrite H' in F; auto. + Qed. + + Lemma exists_spec : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. + unfold Exists; induction s; simpl; intros. + firstorder. discriminate. inv. + destruct (f a) as [ ]_eqn:F. + firstorder. + rewrite IHs; auto. + firstorder. + inv. + setoid_replace a with x in F; auto; congruence. + exists x; auto. + Qed. + + Lemma partition_inf1 : + forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s), + Inf x s -> Inf x (fst (partition f s)). + Proof. + simple induction s; simpl. + intuition. + intros x l Hrec f a Hs Ha; inv. + generalize (Hrec f a H). + case (f x); case (partition f l); simpl. + auto. + intros; apply H2; apply Inf_lt with x; auto. + Qed. + + Lemma partition_inf2 : + forall (s : t) (f : elt -> bool) (x : elt) (Hs : Ok s), + Inf x s -> Inf x (snd (partition f s)). + Proof. + simple induction s; simpl. + intuition. + intros x l Hrec f a Hs Ha; inv. + generalize (Hrec f a H). + case (f x); case (partition f l); simpl. + intros; apply H2; apply Inf_lt with x; auto. + auto. + Qed. + + Global Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec f Hs; inv. + generalize (Hrec f H); generalize (@partition_inf1 l f x). + case (f x); case (partition f l); simpl; auto. + Qed. + + Global Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec f Hs; inv. + generalize (Hrec f H); generalize (@partition_inf2 l f x). + case (f x); case (partition f l); simpl; auto. + Qed. + + Lemma partition_spec1 : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>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_spec2 : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>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. + + End ForNotations. + + Definition In := InA X.eq. + Instance In_compat : Proper (X.eq==>eq==> iff) In. + Proof. repeat red; intros; rewrite H, H0; auto. Qed. + +(* + Module IN <: IN X. + Definition t := t. + Definition In := In. + Instance In_compat : Proper (X.eq==>eq==>iff) In. + Proof. + intros x x' Ex s s' Es. subst. rewrite Ex; intuition. + Qed. + Definition Equal := Equal. + Definition Empty := Empty. + End IN. + Include MakeSetOrdering X IN. + + Lemma Ok_Above_Add : forall x s, Ok (x::s) -> Above x s /\ Add x s (x::s). + Proof. + intros. + inver Ok. + split. + intros y Hy. eapply Sort_Inf_In; eauto. + red. intuition. inver In; auto. rewrite <- H2; left; auto. + right; auto. + Qed. + + Lemma compare_spec : + forall (s s' : t) (Hs : Ok s) (Hs' : Ok s'), Cmp eq lt (compare s s') s s'. + Proof. + induction s as [|x s IH]; intros [|x' s'] Hs Hs'; simpl; intuition. + destruct (Ok_Above_Add Hs'). + eapply lt_empty_l; eauto. intros y Hy. inver InA. + destruct (Ok_Above_Add Hs). + eapply lt_empty_l; eauto. intros y Hy. inver InA. + destruct (Ok_Above_Add Hs); destruct (Ok_Above_Add Hs'). + inver Ok. unfold Ok in IH. specialize (IH s'). + elim_compare x x'; intros. + destruct (compare s s'); unfold Cmp, flip in IH; auto. + intro y; split; intros; inver InA; try (left; order). + right; rewrite <- IH; auto. + right; rewrite IH; auto. + eapply (@lt_add_eq x x'); eauto. + eapply (@lt_add_eq x' x); eauto. + eapply (@lt_add_lt x x'); eauto. + eapply (@lt_add_lt x' x); eauto. + Qed. +*) + + Module L := MakeListOrdering X. + Definition eq := L.eq. + Definition eq_equiv := L.eq_equiv. + Definition lt l1 l2 := + exists l1', exists l2', Ok l1' /\ Ok l2' /\ + eq l1 l1' /\ eq l2 l2' /\ L.lt l1' l2'. + + Instance lt_strorder : StrictOrder lt. + Proof. + split. + intros s (s1 & s2 & B1 & B2 & E1 & E2 & L). + assert (eqlistA X.eq s1 s2). + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *. + transitivity s; auto. symmetry; auto. + rewrite H in L. + apply (StrictOrder_Irreflexive s2); auto. + intros s1 s2 s3 (s1' & s2' & B1 & B2 & E1 & E2 & L12) + (s2'' & s3' & B2' & B3 & E2' & E3 & L23). + exists s1', s3'; do 4 (split; trivial). + assert (eqlistA X.eq s2' s2''). + apply SortA_equivlistA_eqlistA with (ltA:=X.lt); auto using @ok with *. + transitivity s2; auto. symmetry; auto. + transitivity s2'; auto. + rewrite H; auto. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + intros s1 s2 E12 s3 s4 E34. split. + intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. transitivity s1; auto. symmetry; auto. + split; auto. transitivity s3; auto. symmetry; auto. + intros (s1' & s3' & B1 & B3 & E1 & E3 & LT). + exists s1', s3'; do 2 (split; trivial). + split. transitivity s2; auto. + split; auto. transitivity s4; auto. + Qed. + + Lemma compare_spec_aux : forall s s', Cmp eq L.lt (compare s s') s s'. + Proof. + induction s as [|x s IH]; intros [|x' s']; simpl; intuition. + red; auto. + elim_compare x x'; intros; auto. + specialize (IH s'). + destruct (compare s s'); unfold Cmp, flip, eq in IH; auto. + apply L.eq_cons; auto. + Qed. + + Lemma compare_spec : forall s s', Ok s -> Ok s' -> + Cmp eq lt (compare s s') s s'. + Proof. + intros s s' Hs Hs'. + generalize (compare_spec_aux s s'). + destruct (compare s s'); unfold Cmp, flip in *; auto. + exists s, s'; repeat split; auto using @ok. + exists s', s; repeat split; auto using @ok. + Qed. + +End MakeRaw. + +(** * 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 Raw := MakeRaw X. + Include Raw2Sets X Raw. +End Make. diff --git a/theories/MSets/MSetProperties.v b/theories/MSets/MSetProperties.v new file mode 100644 index 0000000000..24e889eeed --- /dev/null +++ b/theories/MSets/MSetProperties.v @@ -0,0 +1,1183 @@ +(***********************************************************************) +(* 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$ *) + +(** * Finite sets library *) + +(** This functor derives additional properties from [MSetInterface.S]. + Contrary to the functor in [MSetEqProperties] 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 MSetInterface. +Require Import DecidableTypeEx MSetFacts MSetDecide. +Set Implicit Arguments. +Unset Strict Implicit. + +Hint Unfold transpose. + +(** First, a functor for Weak Sets in functorial version. *) + +Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). + Module Import Dec := WDecideOn E M. + Module Import FM := Dec.F (* MSetFacts.WFactsOn E M *). + Import M. + + Lemma In_dec : forall x s, {In x s} + {~ In x s}. + Proof. + intros; generalize (mem_iff s x); case (mem x s); intuition. + Qed. + + Definition Add x s s' := forall y, In y s' <-> E.eq x y \/ In y s. + + Lemma Add_Equal : forall x s s', Add x s s' <-> s' [=] add x s. + Proof. + unfold Add. + split; intros. + red; intros. + rewrite H; clear H. + fsetdec. + fsetdec. + Qed. + + Ltac expAdd := repeat rewrite Add_Equal. + + Section BasicProperties. + + Variable s s' s'' s1 s2 s3 : t. + Variable x x' : elt. + + Lemma equal_refl : s[=]s. + Proof. fsetdec. Qed. + + Lemma equal_sym : s[=]s' -> s'[=]s. + Proof. fsetdec. Qed. + + Lemma equal_trans : s1[=]s2 -> s2[=]s3 -> s1[=]s3. + Proof. fsetdec. Qed. + + Lemma subset_refl : s[<=]s. + Proof. fsetdec. Qed. + + Lemma subset_trans : s1[<=]s2 -> s2[<=]s3 -> s1[<=]s3. + Proof. fsetdec. Qed. + + Lemma subset_antisym : s[<=]s' -> s'[<=]s -> s[=]s'. + Proof. fsetdec. Qed. + + Lemma subset_equal : s[=]s' -> s[<=]s'. + Proof. fsetdec. Qed. + + Lemma subset_empty : empty[<=]s. + Proof. fsetdec. Qed. + + Lemma subset_remove_3 : s1[<=]s2 -> remove x s1 [<=] s2. + Proof. fsetdec. Qed. + + Lemma subset_diff : s1[<=]s3 -> diff s1 s2 [<=] s3. + Proof. fsetdec. Qed. + + Lemma subset_add_3 : In x s2 -> s1[<=]s2 -> add x s1 [<=] s2. + Proof. fsetdec. Qed. + + Lemma subset_add_2 : s1[<=]s2 -> s1[<=] add x s2. + Proof. fsetdec. Qed. + + Lemma in_subset : In x s1 -> s1[<=]s2 -> In x s2. + Proof. fsetdec. Qed. + + Lemma double_inclusion : s1[=]s2 <-> s1[<=]s2 /\ s2[<=]s1. + Proof. intuition fsetdec. Qed. + + Lemma empty_is_empty_1 : Empty s -> s[=]empty. + Proof. fsetdec. Qed. + + Lemma empty_is_empty_2 : s[=]empty -> Empty s. + Proof. fsetdec. Qed. + + Lemma add_equal : In x s -> add x s [=] s. + Proof. fsetdec. Qed. + + Lemma add_add : add x (add x' s) [=] add x' (add x s). + Proof. fsetdec. Qed. + + Lemma remove_equal : ~ In x s -> remove x s [=] s. + Proof. fsetdec. Qed. + + Lemma Equal_remove : s[=]s' -> remove x s [=] remove x s'. + Proof. fsetdec. Qed. + + Lemma add_remove : In x s -> add x (remove x s) [=] s. + Proof. fsetdec. Qed. + + Lemma remove_add : ~In x s -> remove x (add x s) [=] s. + Proof. fsetdec. Qed. + + Lemma singleton_equal_add : singleton x [=] add x empty. + Proof. fsetdec. Qed. + + Lemma remove_singleton_empty : + In x s -> remove x s [=] empty -> singleton x [=] s. + Proof. fsetdec. Qed. + + Lemma union_sym : union s s' [=] union s' s. + Proof. fsetdec. Qed. + + Lemma union_subset_equal : s[<=]s' -> union s s' [=] s'. + Proof. fsetdec. Qed. + + Lemma union_equal_1 : s[=]s' -> union s s'' [=] union s' s''. + Proof. fsetdec. Qed. + + Lemma union_equal_2 : s'[=]s'' -> union s s' [=] union s s''. + Proof. fsetdec. Qed. + + Lemma union_assoc : union (union s s') s'' [=] union s (union s' s''). + Proof. fsetdec. Qed. + + Lemma add_union_singleton : add x s [=] union (singleton x) s. + Proof. fsetdec. Qed. + + Lemma union_add : union (add x s) s' [=] add x (union s s'). + Proof. fsetdec. Qed. + + Lemma union_remove_add_1 : + union (remove x s) (add x s') [=] union (add x s) (remove x s'). + Proof. fsetdec. Qed. + + Lemma union_remove_add_2 : In x s -> + union (remove x s) (add x s') [=] union s s'. + Proof. fsetdec. Qed. + + Lemma union_subset_1 : s [<=] union s s'. + Proof. fsetdec. Qed. + + Lemma union_subset_2 : s' [<=] union s s'. + Proof. fsetdec. Qed. + + Lemma union_subset_3 : s[<=]s'' -> s'[<=]s'' -> union s s' [<=] s''. + Proof. fsetdec. Qed. + + Lemma union_subset_4 : s[<=]s' -> union s s'' [<=] union s' s''. + Proof. fsetdec. Qed. + + Lemma union_subset_5 : s[<=]s' -> union s'' s [<=] union s'' s'. + Proof. fsetdec. Qed. + + Lemma empty_union_1 : Empty s -> union s s' [=] s'. + Proof. fsetdec. Qed. + + Lemma empty_union_2 : Empty s -> union s' s [=] s'. + Proof. fsetdec. Qed. + + Lemma not_in_union : ~In x s -> ~In x s' -> ~In x (union s s'). + Proof. fsetdec. Qed. + + Lemma inter_sym : inter s s' [=] inter s' s. + Proof. fsetdec. Qed. + + Lemma inter_subset_equal : s[<=]s' -> inter s s' [=] s. + Proof. fsetdec. Qed. + + Lemma inter_equal_1 : s[=]s' -> inter s s'' [=] inter s' s''. + Proof. fsetdec. Qed. + + Lemma inter_equal_2 : s'[=]s'' -> inter s s' [=] inter s s''. + Proof. fsetdec. Qed. + + Lemma inter_assoc : inter (inter s s') s'' [=] inter s (inter s' s''). + Proof. fsetdec. Qed. + + Lemma union_inter_1 : inter (union s s') s'' [=] union (inter s s'') (inter s' s''). + Proof. fsetdec. Qed. + + Lemma union_inter_2 : union (inter s s') s'' [=] inter (union s s'') (union s' s''). + Proof. fsetdec. Qed. + + Lemma inter_add_1 : In x s' -> inter (add x s) s' [=] add x (inter s s'). + Proof. fsetdec. Qed. + + Lemma inter_add_2 : ~ In x s' -> inter (add x s) s' [=] inter s s'. + Proof. fsetdec. Qed. + + Lemma empty_inter_1 : Empty s -> Empty (inter s s'). + Proof. fsetdec. Qed. + + Lemma empty_inter_2 : Empty s' -> Empty (inter s s'). + Proof. fsetdec. Qed. + + Lemma inter_subset_1 : inter s s' [<=] s. + Proof. fsetdec. Qed. + + Lemma inter_subset_2 : inter s s' [<=] s'. + Proof. fsetdec. Qed. + + Lemma inter_subset_3 : + s''[<=]s -> s''[<=]s' -> s''[<=] inter s s'. + Proof. fsetdec. Qed. + + Lemma empty_diff_1 : Empty s -> Empty (diff s s'). + Proof. fsetdec. Qed. + + Lemma empty_diff_2 : Empty s -> diff s' s [=] s'. + Proof. fsetdec. Qed. + + Lemma diff_subset : diff s s' [<=] s. + Proof. fsetdec. Qed. + + Lemma diff_subset_equal : s[<=]s' -> diff s s' [=] empty. + Proof. fsetdec. Qed. + + Lemma remove_diff_singleton : + remove x s [=] diff s (singleton x). + Proof. fsetdec. Qed. + + Lemma diff_inter_empty : inter (diff s s') (inter s s') [=] empty. + Proof. fsetdec. Qed. + + Lemma diff_inter_all : union (diff s s') (inter s s') [=] s. + Proof. fsetdec. Qed. + + Lemma Add_add : Add x s (add x s). + Proof. expAdd; fsetdec. Qed. + + Lemma Add_remove : In x s -> Add x (remove x s) s. + Proof. expAdd; fsetdec. Qed. + + Lemma union_Add : Add x s s' -> Add x (union s s'') (union s' s''). + Proof. expAdd; fsetdec. Qed. + + Lemma inter_Add : + In x s'' -> Add x s s' -> Add x (inter s s'') (inter s' s''). + Proof. expAdd; fsetdec. Qed. + + Lemma union_Equal : + In x s'' -> Add x s s' -> union s s'' [=] union s' s''. + Proof. expAdd; fsetdec. Qed. + + Lemma inter_Add_2 : + ~In x s'' -> Add x s s' -> inter s s'' [=] inter s' s''. + Proof. expAdd; fsetdec. Qed. + + End BasicProperties. + + Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. + Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym + subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 + subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal + remove_equal singleton_equal_add union_subset_equal union_equal_1 + union_equal_2 union_assoc add_union_singleton union_add union_subset_1 + union_subset_2 union_subset_3 inter_subset_equal inter_equal_1 inter_equal_2 + inter_assoc union_inter_1 union_inter_2 inter_add_1 inter_add_2 + empty_inter_1 empty_inter_2 empty_union_1 empty_union_2 empty_diff_1 + empty_diff_2 union_Add inter_Add union_Equal inter_Add_2 not_in_union + inter_subset_1 inter_subset_2 inter_subset_3 diff_subset diff_subset_equal + remove_diff_singleton diff_inter_empty diff_inter_all Add_add Add_remove + Equal_remove add_add : set. + + (** * Properties of elements *) + + Lemma elements_Empty : forall s, Empty s <-> elements s = nil. + Proof. + intros. + unfold Empty. + split; intros. + assert (forall a, ~ List.In a (elements s)). + red; intros. + apply (H a). + rewrite elements_iff. + rewrite InA_alt; exists a; auto. + destruct (elements s); auto. + elim (H0 e); simpl; auto. + red; intros. + rewrite elements_iff in H0. + rewrite InA_alt in H0; destruct H0. + rewrite H in H0; destruct H0 as (_,H0); inversion H0. + Qed. + + Lemma elements_empty : elements empty = nil. + Proof. + rewrite <-elements_Empty; auto with set. + Qed. + + (** * Conversions between lists and sets *) + + Definition of_list (l : list elt) := List.fold_right add empty l. + + Definition to_list := elements. + + Lemma of_list_1 : forall l x, In x (of_list l) <-> InA E.eq x l. + Proof. + induction l; simpl; intro x. + rewrite empty_iff, InA_nil. intuition. + rewrite add_iff, InA_cons, IHl. intuition. + Qed. + + Lemma of_list_2 : forall l, equivlistA E.eq (to_list (of_list l)) l. + Proof. + unfold to_list; red; intros. + rewrite <- elements_iff; apply of_list_1. + Qed. + + Lemma of_list_3 : forall s, of_list (to_list s) [=] s. + Proof. + unfold to_list; red; intros. + rewrite of_list_1; symmetry; apply elements_iff. + Qed. + + (** * Fold *) + + Section Fold. + + Notation NoDup := (NoDupA E.eq). + Notation InA := (InA E.eq). + + (** ** Induction principles for fold (contributed by S. Lescuyer) *) + + (** In the following lemma, the step hypothesis is deliberately restricted + to the precise set s we are considering. *) + + Theorem fold_rec : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), + (forall s', Empty s' -> P s' i) -> + (forall x a s' s'', In x s -> ~In x s' -> Add x s' s'' -> + P s' a -> P s'' (f x a)) -> + P s (fold f s i). + Proof. + intros A P f i s Pempty Pstep. + rewrite fold_1; unfold flip; rewrite <- fold_left_rev_right. + set (l:=rev (elements s)). + assert (Pstep' : forall x a s' s'', InA x l -> ~In x s' -> Add x s' s'' -> + P s' a -> P s'' (f x a)). + intros; eapply Pstep; eauto. + rewrite elements_iff, <- InA_rev; auto with *. + assert (Hdup : NoDup l) by + (unfold l; eauto using elements_3w, NoDupA_rev with *). + assert (Hsame : forall x, In x s <-> InA x l) by + (unfold l; intros; rewrite elements_iff, InA_rev; intuition). + clear Pstep; clearbody l; revert s Hsame; induction l. + (* empty *) + intros s Hsame; simpl. + apply Pempty. intro x. rewrite Hsame, InA_nil; intuition. + (* step *) + intros s Hsame; simpl. + apply Pstep' with (of_list l); auto. + inversion_clear Hdup; rewrite of_list_1; auto. + red. intros. rewrite Hsame, of_list_1, InA_cons; intuition. + apply IHl. + intros; eapply Pstep'; eauto. + inversion_clear Hdup; auto. + exact (of_list_1 l). + Qed. + + (** Same, with [empty] and [add] instead of [Empty] and [Add]. In this + case, [P] must be compatible with equality of sets *) + + Theorem fold_rec_bis : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A)(s:t), + (forall s s' a, s[=]s' -> P s a -> P s' a) -> + (P empty i) -> + (forall x a s', In x s -> ~In x s' -> P s' a -> P (add x s') (f x a)) -> + P s (fold f s i). + Proof. + intros A P f i s Pmorphism Pempty Pstep. + apply fold_rec; intros. + apply Pmorphism with empty; auto with set. + rewrite Add_Equal in H1; auto with set. + apply Pmorphism with (add x s'); auto with set. + Qed. + + Lemma fold_rec_nodep : + forall (A:Type)(P : A -> Type)(f : elt -> A -> A)(i:A)(s:t), + P i -> (forall x a, In x s -> P a -> P (f x a)) -> + P (fold f s i). + Proof. + intros; apply fold_rec_bis with (P:=fun _ => P); auto. + Qed. + + (** [fold_rec_weak] is a weaker principle than [fold_rec_bis] : + the step hypothesis must here be applicable to any [x]. + At the same time, it looks more like an induction principle, + and hence can be easier to use. *) + + Lemma fold_rec_weak : + forall (A:Type)(P : t -> A -> Type)(f : elt -> A -> A)(i:A), + (forall s s' a, s[=]s' -> P s a -> P s' a) -> + P empty i -> + (forall x a s, ~In x s -> P s a -> P (add x s) (f x a)) -> + forall s, P s (fold f s i). + Proof. + intros; apply fold_rec_bis; auto. + Qed. + + Lemma fold_rel : + forall (A B:Type)(R : A -> B -> Type) + (f : elt -> A -> A)(g : elt -> B -> B)(i : A)(j : B)(s : t), + R i j -> + (forall x a b, In x s -> R a b -> R (f x a) (g x b)) -> + R (fold f s i) (fold g s j). + Proof. + intros A B R f g i j s Rempty Rstep. + do 2 (rewrite fold_1; unfold flip; rewrite <- fold_left_rev_right). + set (l:=rev (elements s)). + assert (Rstep' : forall x a b, InA x l -> R a b -> R (f x a) (g x b)) by + (intros; apply Rstep; auto; rewrite elements_iff, <- InA_rev; auto with *). + clearbody l; clear Rstep s. + induction l; simpl; auto. + Qed. + + (** From the induction principle on [fold], we can deduce some general + induction principles on sets. *) + + Lemma set_induction : + forall P : t -> Type, + (forall s, Empty s -> P s) -> + (forall s s', P s -> forall x, ~In x s -> Add x s s' -> P s') -> + forall s, P s. + Proof. + intros. apply (@fold_rec _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. + Qed. + + Lemma set_induction_bis : + forall P : t -> Type, + (forall s s', s [=] s' -> P s -> P s') -> + P empty -> + (forall x s, ~In x s -> P s -> P (add x s)) -> + forall s, P s. + Proof. + intros. + apply (@fold_rec_bis _ (fun s _ => P s) (fun _ _ => tt) tt s); eauto. + Qed. + + (** [fold] can be used to reconstruct the same initial set. *) + + Lemma fold_identity : forall s, fold add s empty [=] s. + Proof. + intros. + apply fold_rec with (P:=fun s acc => acc[=]s); auto with set. + intros. rewrite H2; rewrite Add_Equal in H1; auto with set. + Qed. + + (** ** Alternative (weaker) specifications for [fold] *) + + (** When [MSets] was first designed, the order in which Ocaml's [Set.fold] + takes the set elements was unspecified. This specification reflects + this fact: + *) + + Lemma fold_0 : + forall s (A : Type) (i : A) (f : elt -> A -> A), + exists l : list elt, + NoDup l /\ + (forall x : elt, In x s <-> InA x l) /\ + fold f s i = fold_right f i l. + Proof. + intros; exists (rev (elements s)); split. + apply NoDupA_rev; auto with *. + split; intros. + rewrite elements_iff; do 2 rewrite InA_alt. + split; destruct 1; generalize (In_rev (elements s) x0); exists x0; intuition. + 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 : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Empty s -> eqA (fold f s i) i. + Proof. + unfold Empty; intros; destruct (fold_0 s i f) as (l,(H1, (H2, H3))). + rewrite H3; clear H3. + generalize H H2; clear H H2; case l; simpl; intros. + reflexivity. + elim (H e). + elim (H2 e); intuition. + Qed. + + Lemma fold_2 : + forall s s' x (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Proper (E.eq==>eqA==>eqA) f -> + transpose eqA f -> + ~ In x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). + Proof. + intros; destruct (fold_0 s i f) as (l,(Hl, (Hl1, Hl2))); + destruct (fold_0 s' i f) as (l',(Hl', (Hl'1, Hl'2))). + rewrite Hl2; rewrite Hl'2; clear Hl2 Hl'2. + apply fold_right_add with (eqA:=E.eq)(eqB:=eqA); auto. + eauto with *. + rewrite <- Hl1; auto. + intros a; rewrite InA_cons; rewrite <- Hl1; rewrite <- Hl'1; + rewrite (H2 a); intuition. + Qed. + + (** In fact, [fold] on empty sets is more than equivalent to + the initial element, it is Leibniz-equal to it. *) + + Lemma fold_1b : + forall s (A : Type)(i : A) (f : elt -> A -> A), + Empty s -> (fold f s i) = i. + Proof. + intros. + rewrite FM.fold_1. + rewrite elements_Empty in H; rewrite H; simpl; auto. + Qed. + + Section Fold_More. + + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f). + + Lemma fold_commutes : forall i s x, + eqA (fold f s (f x i)) (f x (fold f s i)). + Proof. + intros. + apply fold_rel with (R:=fun u v => eqA u (f x v)); intros. + reflexivity. + transitivity (f x0 (f x b)); auto. + apply Comp; auto. + Qed. + + (** ** Fold is a morphism *) + + Lemma fold_init : forall i i' s, eqA i i' -> + eqA (fold f s i) (fold f s i'). + Proof. + intros. apply fold_rel with (R:=eqA); auto. + intros; apply Comp; auto. + Qed. + + Lemma fold_equal : + forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). + Proof. + intros i s; pattern s; apply set_induction; clear s; intros. + transitivity i. + apply fold_1; auto. + symmetry; apply fold_1; auto. + rewrite <- H0; auto. + transitivity (f x (fold f s i)). + apply fold_2 with (eqA := eqA); auto. + symmetry; apply fold_2 with (eqA := eqA); auto. + unfold Add in *; intros. + rewrite <- H2; auto. + Qed. + + (** ** Fold and other set operators *) + + Lemma fold_empty : forall i, fold f empty i = i. + Proof. + intros i; apply fold_1b; auto with set. + Qed. + + Lemma fold_add : forall i s x, ~In x s -> + eqA (fold f (add x s) i) (f x (fold f s i)). + Proof. + intros; apply fold_2 with (eqA := eqA); auto with set. + Qed. + + Lemma add_fold : forall i s x, In x s -> + eqA (fold f (add x s) i) (fold f s i). + Proof. + intros; apply fold_equal; auto with set. + Qed. + + Lemma remove_fold_1: forall i s x, In x s -> + eqA (f x (fold f (remove x s) i)) (fold f s i). + Proof. + intros. + symmetry. + apply fold_2 with (eqA:=eqA); auto with set. + Qed. + + Lemma remove_fold_2: forall i s x, ~In x s -> + eqA (fold f (remove x s) i) (fold f s i). + Proof. + intros. + apply fold_equal; auto with set. + Qed. + + Lemma fold_union_inter : forall i s s', + eqA (fold f (union s s') (fold f (inter s s') i)) + (fold f s (fold f s' i)). + Proof. + intros; pattern s; apply set_induction; clear s; intros. + transitivity (fold f s' (fold f (inter s s') i)). + apply fold_equal; auto with set. + transitivity (fold f s' i). + apply fold_init; auto. + apply fold_1; auto with set. + symmetry; apply fold_1; auto. + rename s'0 into s''. + destruct (In_dec x s'). + (* In x s' *) + transitivity (fold f (union s'' s') (f x (fold f (inter s s') i))); auto with set. + apply fold_init; auto. + apply fold_2 with (eqA:=eqA); auto with set. + rewrite inter_iff; intuition. + transitivity (f x (fold f s (fold f s' i))). + transitivity (fold f (union s s') (f x (fold f (inter s s') i))). + apply fold_equal; auto. + apply equal_sym; apply union_Equal with x; auto with set. + transitivity (f x (fold f (union s s') (fold f (inter s s') i))). + apply fold_commutes; auto. + apply Comp; auto. + symmetry; apply fold_2 with (eqA:=eqA); auto. + (* ~(In x s') *) + transitivity (f x (fold f (union s s') (fold f (inter s'' s') i))). + apply fold_2 with (eqA:=eqA); auto with set. + transitivity (f x (fold f (union s s') (fold f (inter s s') i))). + apply Comp;auto. + apply fold_init;auto. + apply fold_equal;auto. + apply equal_sym; apply inter_Add_2 with x; auto with set. + transitivity (f x (fold f s (fold f s' i))). + apply Comp; auto. + symmetry; apply fold_2 with (eqA:=eqA); auto. + Qed. + + Lemma fold_diff_inter : forall i s s', + eqA (fold f (diff s s') (fold f (inter s s') i)) (fold f s i). + Proof. + intros. + transitivity (fold f (union (diff s s') (inter s s')) + (fold f (inter (diff s s') (inter s s')) i)). + symmetry; apply fold_union_inter; auto. + transitivity (fold f s (fold f (inter (diff s s') (inter s s')) i)). + apply fold_equal; auto with set. + apply fold_init; auto. + apply fold_1; auto with set. + Qed. + + Lemma fold_union: forall i s s', + (forall x, ~(In x s/\In x s')) -> + eqA (fold f (union s s') i) (fold f s (fold f s' i)). + Proof. + intros. + transitivity (fold f (union s s') (fold f (inter s s') i)). + apply fold_init; auto. + symmetry; apply fold_1; auto with set. + unfold Empty; intro a; generalize (H a); set_iff; tauto. + apply fold_union_inter; auto. + Qed. + + End Fold_More. + + Lemma fold_plus : + forall s p, fold (fun _ => S) s p = fold (fun _ => S) s 0 + p. + Proof. + intros. apply fold_rel with (R:=fun u v => u = v + p); simpl; auto. + Qed. + + End Fold. + + (** * Cardinal *) + + (** ** Characterization of cardinal in terms of fold *) + + Lemma cardinal_fold : forall s, cardinal s = fold (fun _ => S) s 0. + Proof. + intros; rewrite cardinal_1; rewrite FM.fold_1. + symmetry; apply fold_left_length; auto. + Qed. + + (** ** Old specifications for [cardinal]. *) + + Lemma cardinal_0 : + forall s, exists l : list elt, + NoDupA E.eq l /\ + (forall x : elt, In x s <-> InA E.eq x l) /\ + cardinal s = length l. + Proof. + intros; exists (elements s); intuition; apply cardinal_1. + Qed. + + Lemma cardinal_1 : forall s, Empty s -> cardinal s = 0. + Proof. + intros; rewrite cardinal_fold; apply fold_1; auto with *. + 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. + split; congruence. + congruence. + Qed. + + (** ** Cardinal and (non-)emptiness *) + + Lemma cardinal_Empty : forall s, Empty s <-> cardinal s = 0. + Proof. + intros. + rewrite elements_Empty, FM.cardinal_1. + destruct (elements s); intuition; discriminate. + Qed. + + Lemma cardinal_inv_1 : forall s, cardinal s = 0 -> Empty s. + Proof. + intros; rewrite cardinal_Empty; auto. + Qed. + Hint Resolve cardinal_inv_1. + + Lemma cardinal_inv_2 : + forall s n, cardinal s = S n -> { x : elt | In x s }. + Proof. + intros; rewrite FM.cardinal_1 in H. + generalize (elements_2 (s:=s)). + destruct (elements s); try discriminate. + exists e; auto. + Qed. + + Lemma cardinal_inv_2b : + forall s, cardinal s <> 0 -> { x : elt | In x s }. + Proof. + intro; generalize (@cardinal_inv_2 s); destruct cardinal; + [intuition|eauto]. + Qed. + + (** ** Cardinal is a morphism *) + + Lemma Equal_cardinal : forall s s', s[=]s' -> cardinal s = cardinal s'. + Proof. + symmetry. + remember (cardinal s) as n; symmetry in Heqn; revert s s' Heqn H. + induction n; intros. + apply cardinal_1; rewrite <- H; auto. + destruct (cardinal_inv_2 Heqn) as (x,H2). + revert Heqn. + rewrite (cardinal_2 (s:=remove x s) (s':=s) (x:=x)); auto with set. + rewrite (cardinal_2 (s:=remove x s') (s':=s') (x:=x)); eauto with set. + Qed. + + Add Morphism cardinal : cardinal_m. + Proof. + exact Equal_cardinal. + Qed. + + Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal. + + (** ** Cardinal and set operators *) + + Lemma empty_cardinal : cardinal empty = 0. + Proof. + rewrite cardinal_fold; apply fold_1; auto with *. + Qed. + + Hint Immediate empty_cardinal cardinal_1 : set. + + Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. + Proof. + intros. + rewrite (singleton_equal_add x). + replace 0 with (cardinal empty); auto with set. + apply cardinal_2 with x; auto with set. + Qed. + + Hint Resolve singleton_cardinal: set. + + Lemma diff_inter_cardinal : + forall s s', cardinal (diff s s') + cardinal (inter s s') = cardinal s . + Proof. + intros; do 3 rewrite cardinal_fold. + rewrite <- fold_plus. + apply fold_diff_inter with (eqA:=@Logic.eq nat); auto with *. + congruence. + 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. + split; congruence. + congruence. + Qed. + + Lemma subset_cardinal : + forall s s', s[<=]s' -> cardinal s <= cardinal s' . + Proof. + intros. + rewrite <- (diff_inter_cardinal s' s). + rewrite (inter_sym s' s). + rewrite (inter_subset_equal H); auto with arith. + Qed. + + Lemma subset_cardinal_lt : + forall s s' x, s[<=]s' -> In x s' -> ~In x s -> cardinal s < cardinal s'. + Proof. + intros. + rewrite <- (diff_inter_cardinal s' s). + rewrite (inter_sym s' s). + rewrite (inter_subset_equal H). + generalize (@cardinal_inv_1 (diff s' s)). + destruct (cardinal (diff s' s)). + intro H2; destruct (H2 (refl_equal _) x). + set_iff; auto. + intros _. + change (0 + cardinal s < S n + cardinal s). + apply Plus.plus_lt_le_compat; auto with arith. + Qed. + + Theorem union_inter_cardinal : + forall s s', cardinal (union s s') + cardinal (inter s s') = cardinal s + cardinal s' . + Proof. + intros. + do 4 rewrite cardinal_fold. + do 2 rewrite <- fold_plus. + apply fold_union_inter with (eqA:=@Logic.eq nat); auto with *. + congruence. + Qed. + + Lemma union_cardinal_inter : + forall s s', cardinal (union s s') = cardinal s + cardinal s' - cardinal (inter s s'). + Proof. + intros. + rewrite <- union_inter_cardinal. + rewrite Plus.plus_comm. + auto with arith. + Qed. + + Lemma union_cardinal_le : + forall s s', cardinal (union s s') <= cardinal s + cardinal s'. + Proof. + intros; generalize (union_inter_cardinal s s'). + intros; rewrite <- H; auto with arith. + Qed. + + Lemma add_cardinal_1 : + forall s x, In x s -> cardinal (add x s) = cardinal s. + Proof. + auto with set. + Qed. + + Lemma add_cardinal_2 : + forall s x, ~In x s -> cardinal (add x s) = S (cardinal s). + Proof. + intros. + do 2 rewrite cardinal_fold. + change S with ((fun _ => S) x); + apply fold_add with (eqA:=@Logic.eq nat); auto with *. + congruence. + Qed. + + Lemma remove_cardinal_1 : + forall s x, In x s -> S (cardinal (remove x s)) = cardinal s. + Proof. + intros. + do 2 rewrite cardinal_fold. + change S with ((fun _ =>S) x). + apply remove_fold_1 with (eqA:=@Logic.eq nat); auto with *. + congruence. + 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 WPropertiesOn. + +(** Now comes variants for self-contained weak sets and for full sets. + For these variants, only one argument is necessary. Thanks to + the subtyping [WS<=S], the [Properties] functor which is meant to be + used on modules [(M:S)] can simply be an alias of [WProperties]. *) + +Module WProperties (M:WSets) := WPropertiesOn M.E M. +Module Properties := WProperties. + + +(** Now comes some properties specific to the element ordering, + invalid for Weak Sets. *) + +Module OrdProperties (M:Sets). + Module ME:=OrderedTypeFacts(M.E). + Module Import P := Properties M. + Import FM. + Import M.E. + Import M. + + Hint Resolve elements_spec2. + Hint Immediate + min_elt_spec1 min_elt_spec2 min_elt_spec3 + max_elt_spec1 max_elt_spec2 max_elt_spec3 : set. + + (** First, a specialized version of SortA_equivlistA_eqlistA: *) + Lemma sort_equivlistA_eqlistA : forall l l' : list elt, + sort E.lt l -> sort E.lt l' -> equivlistA E.eq l l' -> eqlistA E.eq l l'. + Proof. + apply SortA_equivlistA_eqlistA; eauto with *. + Qed. + + Definition gtb x y := match E.compare x y with Gt => true | _ => false end. + Definition leb x := fun y => negb (gtb x y). + + Definition elements_lt x s := List.filter (gtb x) (elements s). + Definition elements_ge x s := List.filter (leb x) (elements s). + + Lemma gtb_1 : forall x y, gtb x y = true <-> E.lt y x. + Proof. + intros; unfold gtb; ME.elim_compare x y; intuition; try discriminate; ME.order. + Qed. + + Lemma leb_1 : forall x y, leb x y = true <-> ~E.lt y x. + Proof. + intros; unfold leb, gtb; ME.elim_compare x y; intuition; try discriminate; ME.order. + Qed. + + Lemma gtb_compat : forall x, Proper (E.eq==>Logic.eq) (gtb x). + Proof. + red; intros x a b H. + generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto. + intros. + symmetry; rewrite H1. + apply ME.eq_lt with a; auto. + rewrite <- H0; auto. + intros. + rewrite H0. + apply ME.eq_lt with b; auto. + rewrite <- H1; auto. + Qed. + + Lemma leb_compat : forall x, Proper (E.eq==>Logic.eq) (leb x). + Proof. + red; intros x a b H; unfold leb. + f_equal; apply gtb_compat; auto. + Qed. + Hint Resolve gtb_compat leb_compat. + + Lemma elements_split : forall x s, + elements s = elements_lt x s ++ elements_ge x s. + Proof. + unfold elements_lt, elements_ge, leb; intros. + eapply (@filter_split _ E.eq); eauto with *. + intros. + rewrite gtb_1 in H. + assert (~E.lt y x). + unfold gtb in *; ME.elim_compare x y; intuition; + try discriminate; ME.order. + ME.order. + Qed. + + Lemma elements_Add : forall s s' x, ~In x s -> Add x s s' -> + eqlistA E.eq (elements s') (elements_lt x s ++ x :: elements_ge x s). + Proof. + intros; unfold elements_ge, elements_lt. + apply sort_equivlistA_eqlistA; auto with set. + apply (@SortA_app _ E.eq); auto with *. + apply (@filter_sort _ E.eq); auto with *; eauto with *. + constructor; auto. + apply (@filter_sort _ E.eq); auto with *; eauto with *. + rewrite ME.Inf_alt by (apply (@filter_sort _ E.eq); eauto with *). + intros. + rewrite filter_InA in H1; auto with *; destruct H1. + rewrite leb_1 in H2. + rewrite <- elements_iff in H1. + assert (~E.eq x y). + contradict H; rewrite H; auto. + ME.order. + intros. + rewrite filter_InA in H1; auto with *; destruct H1. + rewrite gtb_1 in H3. + inversion_clear H2. + ME.order. + rewrite filter_InA in H4; auto with *; destruct H4. + rewrite leb_1 in H4. + ME.order. + red; intros a. + rewrite InA_app_iff, InA_cons, !filter_InA, <-!elements_iff, + leb_1, gtb_1, (H0 a) by (auto with *). + intuition. + ME.elim_compare a x; intuition. + right; right; split; auto. + ME.order. + Qed. + + Definition Above x s := forall y, In y s -> E.lt y x. + Definition Below x s := forall y, In y s -> E.lt x y. + + Lemma elements_Add_Above : forall s s' x, + Above x s -> Add x s s' -> + eqlistA E.eq (elements s') (elements s ++ x::nil). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with set. + apply (@SortA_app _ E.eq); auto with *. + intros. + inversion_clear H2. + rewrite <- elements_iff in H1. + apply ME.lt_eq with x; auto. + inversion H3. + red; intros a. + rewrite InA_app_iff, InA_cons, InA_nil, <-!elements_iff, (H0 a) + by (auto with *). + intuition. + Qed. + + Lemma elements_Add_Below : forall s s' x, + Below x s -> Add x s s' -> + eqlistA E.eq (elements s') (x::elements s). + Proof. + intros. + apply sort_equivlistA_eqlistA; auto with set. + change (sort E.lt ((x::nil) ++ elements s)). + apply (@SortA_app _ E.eq); auto with *. + intros. + inversion_clear H1. + rewrite <- elements_iff in H2. + apply ME.eq_lt with x; auto. + inversion H3. + red; intros a. + rewrite InA_cons, <- !elements_iff, (H0 a); intuition. + Qed. + + (** Two other induction principles on sets: we can be more restrictive + on the element we add at each step. *) + + Lemma set_induction_max : + forall P : t -> Type, + (forall s : t, Empty s -> P s) -> + (forall s s', P s -> forall x, Above x s -> Add x s s' -> P s') -> + forall s : t, P s. + Proof. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + case_eq (max_elt s); intros. + apply X0 with (remove e s) e; auto with set. + apply IHn. + assert (S n = S (cardinal (remove e s))). + rewrite Heqn; apply cardinal_2 with e; auto with set. + inversion H0; auto. + red; intros. + rewrite remove_iff in H0; destruct H0. + generalize (@max_elt_spec2 s e y H H0); ME.order. + + assert (H0:=max_elt_spec3 H). + rewrite cardinal_Empty in H0; rewrite H0 in Heqn; inversion Heqn. + Qed. + + Lemma set_induction_min : + forall P : t -> Type, + (forall s : t, Empty s -> P s) -> + (forall s s', P s -> forall x, Below x s -> Add x s s' -> P s') -> + forall s : t, P s. + Proof. + intros; remember (cardinal s) as n; revert s Heqn; induction n; intros; auto. + case_eq (min_elt s); intros. + apply X0 with (remove e s) e; auto with set. + apply IHn. + assert (S n = S (cardinal (remove e s))). + rewrite Heqn; apply cardinal_2 with e; auto with set. + inversion H0; auto. + red; intros. + rewrite remove_iff in H0; destruct H0. + generalize (@min_elt_spec2 s e y H H0); ME.order. + + assert (H0:=min_elt_spec3 H). + rewrite cardinal_Empty in H0; auto; rewrite H0 in Heqn; inversion Heqn. + Qed. + + (** More properties of [fold] : behavior with respect to Above/Below *) + + Lemma fold_3 : + forall s s' x (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Proper (E.eq==>eqA==>eqA) f -> + Above x s -> Add x s s' -> eqA (fold f s' i) (f x (fold f s i)). + Proof. + intros. + rewrite !FM.fold_1. + unfold flip; rewrite <-!fold_left_rev_right. + change (f x (fold_right f i (rev (elements s)))) with + (fold_right f i (rev (x::nil)++rev (elements s))). + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto with *. + rewrite <- distr_rev. + apply eqlistA_rev. + apply elements_Add_Above; auto. + Qed. + + Lemma fold_4 : + forall s s' x (A : Type) (eqA : A -> A -> Prop) + (st : Equivalence eqA) (i : A) (f : elt -> A -> A), + Proper (E.eq==>eqA==>eqA) f -> + Below x s -> Add x s s' -> eqA (fold f s' i) (fold f s (f x i)). + Proof. + intros. + rewrite !FM.fold_1. + change (eqA (fold_left (flip f) (elements s') i) + (fold_left (flip f) (x::elements s) i)). + unfold flip; rewrite <-!fold_left_rev_right. + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. + apply eqlistA_rev. + apply elements_Add_Below; auto. + Qed. + + (** The following results have already been proved earlier, + but we can now prove them with one hypothesis less: + no need for [(transpose eqA f)]. *) + + Section FoldOpt. + Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA). + Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f). + + Lemma fold_equal : + forall i s s', s[=]s' -> eqA (fold f s i) (fold f s' i). + Proof. + intros. + rewrite !FM.fold_1. + unfold flip; rewrite <- !fold_left_rev_right. + apply (@fold_right_eqlistA E.t E.eq A eqA st); auto. + apply eqlistA_rev. + apply sort_equivlistA_eqlistA; auto with set. + red; intro a; do 2 rewrite <- elements_iff; auto. + Qed. + + Lemma add_fold : forall i s x, In x s -> + eqA (fold f (add x s) i) (fold f s i). + Proof. + intros; apply fold_equal; auto with set. + Qed. + + Lemma remove_fold_2: forall i s x, ~In x s -> + eqA (fold f (remove x s) i) (fold f s i). + Proof. + intros. + apply fold_equal; auto with set. + Qed. + + End FoldOpt. + + (** An alternative version of [choose_3] *) + + Lemma choose_equal : forall s s', Equal s s' -> + match choose s, choose s' with + | Some x, Some x' => E.eq x x' + | None, None => True + | _, _ => False + end. + Proof. + intros s s' H; + generalize (@choose_spec1 s)(@choose_spec2 s) + (@choose_spec1 s')(@choose_spec2 s')(@choose_spec3 s s'); + destruct (choose s); destruct (choose s'); simpl; intuition. + apply H5 with e; rewrite <-H; auto. + apply H5 with e; rewrite H; auto. + Qed. + +End OrdProperties. diff --git a/theories/MSets/MSetToFiniteSet.v b/theories/MSets/MSetToFiniteSet.v new file mode 100644 index 0000000000..e8f8ab5e9f --- /dev/null +++ b/theories/MSets/MSetToFiniteSet.v @@ -0,0 +1,158 @@ +(***********************************************************************) +(* 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$ *) + +(** * Finite sets library : conversion to old [Finite_sets] *) + +Require Import Ensembles Finite_sets. +Require Import MSetInterface MSetProperties OrderedType2Ex DecidableType2Ex. + +(** * Going from [MSets] with usual Leibniz equality + to the good old [Ensembles] and [Finite_sets] theory. *) + +Module WS_to_Finite_set (U:UsualDecidableType)(M: WSfun U). + Module MP:= WProperties_fun U M. + Import M MP FM Ensembles Finite_sets. + + Definition mkEns : M.t -> Ensemble M.elt := + fun s x => M.In x s. + + Notation " !! " := mkEns. + + Lemma In_In : forall s x, M.In x s <-> In _ (!!s) x. + Proof. + unfold In; compute; auto with extcore. + Qed. + + Lemma Subset_Included : forall s s', s[<=]s' <-> Included _ (!!s) (!!s'). + Proof. + unfold Subset, Included, In, mkEns; intuition. + Qed. + + Notation " a === b " := (Same_set M.elt a b) (at level 70, no associativity). + + Lemma Equal_Same_set : forall s s', s[=]s' <-> !!s === !!s'. + Proof. + intros. + rewrite double_inclusion. + unfold Subset, Included, Same_set, In, mkEns; intuition. + Qed. + + Lemma empty_Empty_Set : !!M.empty === Empty_set _. + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1. + Qed. + + Lemma Empty_Empty_set : forall s, Empty s -> !!s === Empty_set _. + Proof. + unfold Same_set, Included, mkEns, In. + split; intros. + destruct(H x H0). + inversion H0. + Qed. + + Lemma singleton_Singleton : forall x, !!(M.singleton x) === Singleton _ x . + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; try constructor; auto. + Qed. + + Lemma union_Union : forall s s', !!(union s s') === Union _ (!!s) (!!s'). + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; [ constructor 1 | constructor 2 | | ]; auto. + Qed. + + Lemma inter_Intersection : forall s s', !!(inter s s') === Intersection _ (!!s) (!!s'). + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; try constructor; auto. + Qed. + + Lemma add_Add : forall x s, !!(add x s) === Add _ (!!s) x. + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; auto with sets. + inversion H0. + constructor 2; constructor. + constructor 1; auto. + Qed. + + Lemma Add_Add : forall x s s', MP.Add x s s' -> !!s' === Add _ (!!s) x. + Proof. + unfold Same_set, Included, mkEns, In. + split; intros. + red in H; rewrite H in H0. + destruct H0. + inversion H0. + constructor 2; constructor. + constructor 1; auto. + red in H; rewrite H. + inversion H0; auto. + inversion H1; auto. + Qed. + + Lemma remove_Subtract : forall x s, !!(remove x s) === Subtract _ (!!s) x. + Proof. + unfold Same_set, Included, mkEns, In. + split; intro; set_iff; inversion 1; auto with sets. + split; auto. + contradict H1. + inversion H1; auto. + Qed. + + Lemma mkEns_Finite : forall s, Finite _ (!!s). + Proof. + intro s; pattern s; apply set_induction; clear s; intros. + intros; replace (!!s) with (Empty_set elt); auto with sets. + symmetry; apply Extensionality_Ensembles. + apply Empty_Empty_set; auto. + replace (!!s') with (Add _ (!!s) x). + constructor 2; auto. + symmetry; apply Extensionality_Ensembles. + apply Add_Add; auto. + Qed. + + Lemma mkEns_cardinal : forall s, cardinal _ (!!s) (M.cardinal s). + Proof. + intro s; pattern s; apply set_induction; clear s; intros. + intros; replace (!!s) with (Empty_set elt); auto with sets. + rewrite cardinal_1; auto with sets. + symmetry; apply Extensionality_Ensembles. + apply Empty_Empty_set; auto. + replace (!!s') with (Add _ (!!s) x). + rewrite (cardinal_2 H0 H1); auto with sets. + symmetry; apply Extensionality_Ensembles. + apply Add_Add; auto. + Qed. + + (** we can even build a function from Finite Ensemble to MSet + ... at least in Prop. *) + + Lemma Ens_to_MSet : forall e : Ensemble M.elt, Finite _ e -> + exists s:M.t, !!s === e. + Proof. + induction 1. + exists M.empty. + apply empty_Empty_Set. + destruct IHFinite as (s,Hs). + exists (M.add x s). + apply Extensionality_Ensembles in Hs. + rewrite <- Hs. + apply add_Add. + Qed. + +End WS_to_Finite_set. + + +Module S_to_Finite_set (U:UsualOrderedType)(M: Sfun U) := + WS_to_Finite_set U M. + + diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v new file mode 100644 index 0000000000..d5a85e6c2a --- /dev/null +++ b/theories/MSets/MSetWeakList.v @@ -0,0 +1,528 @@ +(***********************************************************************) +(* 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$ *) + +(** * Finite sets library *) + +(** This file proposes an implementation of the non-dependant + interface [MSetWeakInterface.S] using lists without redundancy. *) + +Require Import MSetInterface. +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. *) + + +(** ** The set operations. *) + +Module Ops (X: DecidableType) <: WOps 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. + + Fixpoint mem (x : elt) (s : t) : 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) : 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) : t := + match s with + | nil => nil + | y :: l => + if X.eq_dec x y then l else y :: remove x l + end. + + Definition fold (B : Type) (f : elt -> B -> B) (s : t) (i : B) : B := + fold_left (flip f) s i. + + 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) : 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) : 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) : 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) : 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. + +End Ops. + +(** ** Proofs of set operation specifications. *) + +Module MakeRaw (X:DecidableType) <: WRawSets X. + Include Ops X. + + Section ForNotations. + Notation NoDup := (NoDupA X.eq). + Notation In := (InA X.eq). + + Definition IsOk := NoDup. + + Class Ok (s:t) : Prop := { ok : NoDup s }. + + Hint Constructors Ok. + Hint Resolve @ok. + + Instance NoDup_Ok `(nd : NoDup s) : Ok s := nd. + + Ltac inv_ok := match goal with + | H:Ok (_ :: _) |- _ => apply @ok in H; inversion_clear H; inv_ok + | H:Ok nil |- _ => clear H; inv_ok + | H:NoDup ?l |- _ => generalize (Build_Ok H); clear H; intro H; inv_ok + | _ => idtac + end. + + Ltac inv := invlist InA; inv_ok. + Ltac constructors := repeat constructor. + + Fixpoint isok l := match l with + | nil => true + | a::l => negb (mem a l) && isok l + end. + + 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_compat : Proper (X.eq==>eq==>iff) In. + Proof. + repeat red; intros. subst. rewrite H; auto. + Qed. + + Lemma mem_spec : forall s x `{Ok s}, + mem x s = true <-> In x s. + Proof. + induction s; intros. + split; intros; inv. discriminate. + simpl; destruct (X.eq_dec x a); split; intros; inv; auto. + right; rewrite <- IHs; auto. + rewrite IHs; auto. + Qed. + + Lemma isok_iff : forall l, Ok l <-> isok l = true. + Proof. + induction l. + intuition. + simpl. + rewrite andb_true_iff. + rewrite negb_true_iff. + rewrite <- IHl. + split; intros H. inv. + split; auto. + apply not_true_is_false. rewrite mem_spec; auto. + destruct H; constructors; auto. + rewrite <- mem_spec; auto; congruence. + Qed. + + Global Instance isok_Ok `(isok l = true) : Ok l | 10. + Proof. + intros. apply <- isok_iff; auto. + Qed. + + Lemma add_spec : + forall (s : t) (x y : elt) {Hs : Ok s}, + In y (add x s) <-> X.eq y x \/ In y s. + Proof. + induction s; simpl; intros. + intuition; inv; auto. + destruct X.eq_dec; inv; rewrite InA_cons, ?IHs; intuition. + left; eauto. + inv; auto. + Qed. + + Global Instance add_ok s x `(Ok s) : Ok (add x s). + Proof. + induction s. + simpl; intuition. + intros; inv. simpl. + destruct X.eq_dec; auto. + constructors; auto. + intro; inv; auto. + rewrite add_spec in *; intuition. + Qed. + + Lemma remove_spec : + forall (s : t) (x y : elt) {Hs : Ok s}, + In y (remove x s) <-> In y s /\ ~X.eq y x. + Proof. + induction s; simpl; intros. + intuition; inv; auto. + destruct X.eq_dec; inv; rewrite !InA_cons, ?IHs; intuition. + elim H. setoid_replace a with y; eauto. + elim H3. setoid_replace x with y; eauto. + elim n. eauto. + Qed. + + Global Instance remove_ok s x `(Ok s) : Ok (remove x s). + Proof. + induction s; simpl; intros. + auto. + destruct X.eq_dec; inv; auto. + constructors; auto. + rewrite remove_spec; intuition. + Qed. + + Lemma singleton_ok : forall x : elt, Ok (singleton x). + Proof. + unfold singleton; simpl; constructors; auto. intro; inv. + Qed. + + Lemma singleton_spec : forall x y : elt, In y (singleton x) <-> X.eq y x. + Proof. + unfold singleton; simpl; split; intros. inv; auto. left; auto. + Qed. + + Lemma empty_ok : Ok empty. + Proof. + unfold empty; constructors. + Qed. + + Lemma empty_spec : Empty empty. + Proof. + unfold Empty, empty; red; intros; inv. + Qed. + + Lemma is_empty_spec : forall s : t, is_empty s = true <-> Empty s. + Proof. + unfold Empty; destruct s; simpl; split; intros; auto. + intro; inv. + discriminate. + elim (H e); auto. + Qed. + + Lemma elements_spec1 : forall (s : t) (x : elt), In x (elements s) <-> In x s. + Proof. + unfold elements; intuition. + Qed. + + Lemma elements_spec2w : forall (s : t) {Hs : Ok s}, NoDup (elements s). + Proof. + unfold elements; auto. + Qed. + + Lemma fold_spec : + forall (s : t) (A : Type) (i : A) (f : elt -> A -> A), + fold f s i = fold_left (flip f) (elements s) i. + Proof. + reflexivity. + Qed. + + Global Instance union_ok s s' `(Ok s, Ok s') : Ok (union s s'). + Proof. + induction s; simpl; auto; intros; inv; unfold flip; auto with *. + Qed. + + Lemma union_spec : + forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, + In x (union s s') <-> In x s \/ In x s'. + Proof. + induction s; simpl in *; unfold flip; intros; auto; inv. + intuition; inv. + rewrite IHs, add_spec, InA_cons; intuition. + Qed. + + Global Instance inter_ok s s' `(Ok s, Ok s') : Ok (inter s s'). + Proof. + unfold inter, fold, flip; intros s. + set (acc := nil (A:=elt)). + assert (Hacc : Ok acc) by constructors. + clearbody acc; revert acc Hacc. + induction s; simpl; auto; intros. inv. + apply IHs; auto. + destruct (mem a s'); auto with *. + Qed. + + Lemma inter_spec : + forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, + In x (inter s s') <-> In x s /\ In x s'. + Proof. + unfold inter, fold, flip; intros. + set (acc := nil (A:=elt)) in *. + assert (Hacc : Ok acc) by constructors. + assert (IFF : (In x s /\ In x s') <-> (In x s /\ In x s') \/ In x acc). + intuition; unfold acc in *; inv. + rewrite IFF; clear IFF. clearbody acc. + revert acc Hacc x s' Hs Hs'. + induction s; simpl; intros. + intuition; inv. + inv. + case_eq (mem a s'); intros Hm. + rewrite IHs, add_spec, InA_cons; intuition. + rewrite mem_spec in Hm; auto. + left; split; auto. rewrite H1; auto. + rewrite IHs, InA_cons; intuition. + rewrite H2, <- mem_spec in H3; auto. congruence. + Qed. + + Global Instance diff_ok s s' `(Ok s, Ok s') : Ok (diff s s'). + Proof. + unfold diff; intros s s'; revert s. + induction s'; simpl; unfold flip; auto; intros. inv; auto with *. + Qed. + + Lemma diff_spec : + forall (s s' : t) (x : elt) {Hs : Ok s} {Hs' : Ok s'}, + In x (diff s s') <-> In x s /\ ~In x s'. + Proof. + unfold diff; intros s s'; revert s. + induction s'; simpl; unfold flip. + intuition; inv. + intros. inv. + rewrite IHs', remove_spec, InA_cons; intuition. + Qed. + + Lemma subset_spec : + forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'}, + subset s s' = true <-> Subset s s'. + Proof. + unfold subset, Subset; intros. + rewrite is_empty_spec. + unfold Empty; intros. + intuition. + specialize (H a). rewrite diff_spec in H; intuition. + rewrite <- (mem_spec a) in H |- *. destruct (mem a s'); intuition. + rewrite diff_spec in H0; intuition. + Qed. + + Lemma equal_spec : + forall (s s' : t) {Hs : Ok s} {Hs' : Ok s'}, + equal s s' = true <-> Equal s s'. + Proof. + unfold Equal, equal; intros. + rewrite andb_true_iff, !subset_spec. + unfold Subset; intuition. rewrite <- H; auto. rewrite H; auto. + Qed. + + Definition choose_spec1 : + forall (s : t) (x : elt), choose s = Some x -> In x s. + Proof. + destruct s; simpl; intros; inversion H; auto. + Qed. + + Definition choose_spec2 : forall s : t, choose s = None -> Empty s. + Proof. + destruct s; simpl; intros. + intros x H0; inversion H0. + inversion H. + Qed. + + Lemma cardinal_spec : + forall (s : t) {Hs : Ok s}, cardinal s = length (elements s). + Proof. + auto. + Qed. + + Lemma filter_spec' : forall s x f, + In x (filter f s) -> In x s. + Proof. + induction s; simpl. + intuition; inv. + intros; destruct (f a); inv; intuition; right; eauto. + Qed. + + Lemma filter_spec : + forall (s : t) (x : elt) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (In x (filter f s) <-> In x s /\ f x = true). + Proof. + induction s; simpl. + intuition; inv. + intros. + destruct (f a) as [ ]_eqn:E; rewrite ?InA_cons, IHs; intuition. + setoid_replace x with a; auto. + setoid_replace a with x in E; auto. congruence. + Qed. + + Global Instance filter_ok s f `(Ok s) : Ok (filter f s). + Proof. + induction s; simpl. + auto. + intros; inv. + case (f a); auto. + constructors; auto. + contradict H0. + eapply filter_spec'; eauto. + Qed. + + Lemma for_all_spec : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (for_all f s = true <-> For_all (fun x => f x = true) s). + Proof. + unfold For_all; induction s; simpl. + intuition. inv. + intros; inv. + destruct (f a) as [ ]_eqn:F. + rewrite IHs; intuition. inv; auto. + setoid_replace x with a; auto. + split; intros H'; try discriminate. + intros. + rewrite <- F, <- (H' a); auto. + Qed. + + Lemma exists_spec : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>eq) f -> + (exists_ f s = true <-> Exists (fun x => f x = true) s). + Proof. + unfold Exists; induction s; simpl. + split; [discriminate| intros (x & Hx & _); inv]. + intros. + destruct (f a) as [ ]_eqn:F. + split; auto. + exists a; auto. + rewrite IHs; firstorder. + inv. + setoid_replace a with x in F; auto; congruence. + exists x; auto. + Qed. + + Lemma partition_spec1 : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>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_spec2 : + forall (s : t) (f : elt -> bool), + Proper (X.eq==>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_ok1' : + forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt), + In x (fst (partition f s)) -> In x s. + Proof. + induction s; simpl; auto; intros. inv. + generalize (IHs H1 f x). + destruct (f a); destruct (partition f s); simpl in *; auto. + inversion_clear H; auto. + Qed. + + Lemma partition_ok2' : + forall (s : t) {Hs : Ok s} (f : elt -> bool)(x:elt), + In x (snd (partition f s)) -> In x s. + Proof. + induction s; simpl; auto; intros. inv. + generalize (IHs H1 f x). + destruct (f a); destruct (partition f s); simpl in *; auto. + inversion_clear H; auto. + Qed. + + Global Instance partition_ok1 s f `(Ok s) : Ok (fst (partition f s)). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec f Hs; inv. + generalize (@partition_ok1' _ _ f x). + generalize (Hrec f H0). + case (f x); case (partition f l); simpl; constructors; auto. + Qed. + + Global Instance partition_ok2 s f `(Ok s) : Ok (snd (partition f s)). + Proof. + simple induction s; simpl. + auto. + intros x l Hrec f Hs; inv. + generalize (@partition_ok2' _ _ f x). + generalize (Hrec f H0). + case (f x); case (partition f l); simpl; constructors; auto. + Qed. + + End ForNotations. + + Definition In := InA X.eq. + Definition eq := Equal. + Instance eq_equiv : Equivalence eq. + +End MakeRaw. + +(** * 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) <: WSets with Module E := X. + Module Raw := MakeRaw X. + Include WRaw2Sets X Raw. +End Make. + diff --git a/theories/MSets/MSets.v b/theories/MSets/MSets.v new file mode 100644 index 0000000000..42966c7fc2 --- /dev/null +++ b/theories/MSets/MSets.v @@ -0,0 +1,23 @@ +(***********************************************************************) +(* 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$ *) + +Require Export OrderedType2. +Require Export OrderedType2Ex. +Require Export OrderedType2Alt. +Require Export DecidableType2. +Require Export DecidableType2Ex. +Require Export MSetInterface. +Require Export MSetFacts. +Require Export MSetDecide. +Require Export MSetProperties. +Require Export MSetEqProperties. +Require Export MSetWeakList. +Require Export MSetList. +Require Export MSetAVL.
\ No newline at end of file diff --git a/theories/Logic/DecidableType.v b/theories/Structures/DecidableType.v index 625f776bfa..625f776bfa 100644 --- a/theories/Logic/DecidableType.v +++ b/theories/Structures/DecidableType.v diff --git a/theories/Structures/DecidableType2.v b/theories/Structures/DecidableType2.v new file mode 100644 index 0000000000..0b3ebfa295 --- /dev/null +++ b/theories/Structures/DecidableType2.v @@ -0,0 +1,164 @@ +(***********************************************************************) +(* 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$ *) + +Require Export SetoidList2. +Set Implicit Arguments. +Unset Strict Implicit. + +(** * Types with Equalities, and nothing more (for subtyping purpose) *) + +Module Type EqualityType. + Parameter Inline t : Type. + Parameter Inline eq : t -> t -> Prop. + Instance eq_equiv : Equivalence eq. + + Hint Resolve (@Equivalence_Reflexive _ _ eq_equiv). + Hint Resolve (@Equivalence_Transitive _ _ eq_equiv). + Hint Immediate (@Equivalence_Symmetric _ _ eq_equiv). +End EqualityType. + +(** * Types with decidable Equalities (but no ordering) *) + +Module Type DecidableType. + Include Type EqualityType. + Parameter eq_dec : forall x y : t, { eq x y } + { ~ eq x y }. +End DecidableType. + +(** * Additional notions about keys and datas used in FMap *) + +Module KeyDecidableType(D:DecidableType). + Import D. + + Section Elt. + Variable elt : Type. + Notation key:=t. + + Definition eqk (p p':key*elt) := eq (fst p) (fst p'). + Definition eqke (p p':key*elt) := + eq (fst p) (fst p') /\ (snd p) = (snd p'). + + Global Hint Unfold eqk eqke. + Global 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 *) + + Instance eqk_equiv : Equivalence eqk. + Proof. + constructor; eauto. + Qed. + + Instance eqke_equiv : Equivalence eqke. + Proof. + constructor. auto. + red; unfold eqke; intuition. + red; unfold eqke; intuition; [ eauto | congruence ]. + Qed. + + Global Hint Resolve (@Equivalence_Reflexive _ _ eqk_equiv). + Global Hint Resolve (@Equivalence_Transitive _ _ eqk_equiv). + Global Hint Immediate (@Equivalence_Symmetric _ _ eqk_equiv). + Global Hint Resolve (@Equivalence_Reflexive _ _ eqke_equiv). + Global Hint Resolve (@Equivalence_Transitive _ _ eqke_equiv). + Global Hint Immediate (@Equivalence_Symmetric _ _ eqke_equiv). + + Lemma InA_eqke_eqk : + forall x m, InA eqke x m -> InA eqk x m. + Proof. + unfold eqke; induction 1; intuition. + Qed. + Global 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. rewrite <- H; auto. + Qed. + + Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). + Definition In k m := exists e:elt, MapsTo k e m. + + Global 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. + + Global Instance MapsTo_compat : + Proper (eq==>Logic.eq==>Logic.eq==>iff) MapsTo. + Proof. + intros x x' Hxx' e e' Hee' l l' Hll'; subst. + unfold MapsTo. + assert (EQN : eqke (x,e') (x',e')) by (compute;auto). + rewrite EQN; intuition. + Qed. + + Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. + Proof. + intros; rewrite <- H; auto. + Qed. + + Global Instance In_compat : Proper (eq==>Logic.eq==>iff) In. + Proof. + intros x x' Hxx' l l' Hll'; subst l. + unfold In. + split; intros (e,He); exists e. + rewrite <- Hxx'; auto. + rewrite Hxx'; auto. + Qed. + + Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. + Proof. + intros; rewrite <- H; auto. + 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 Resolve In_inv_2 In_inv_3. + +End KeyDecidableType. + + + + + diff --git a/theories/Structures/DecidableType2Ex.v b/theories/Structures/DecidableType2Ex.v new file mode 100644 index 0000000000..7b9c052ec4 --- /dev/null +++ b/theories/Structures/DecidableType2Ex.v @@ -0,0 +1,85 @@ +(***********************************************************************) +(* 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$ *) + +Require Import DecidableType2. +Set Implicit Arguments. +Unset Strict Implicit. + +(** * Examples of Decidable Type structures. *) + +(** A particular case of [DecidableType] where + the equality is the usual one of Coq. *) + +Module Type UsualDecidableType. + Parameter Inline t : Type. + Definition eq := @eq t. + Program Instance eq_equiv : Equivalence eq. + Parameter eq_dec : forall x y, { eq x y }+{~eq x y }. +End UsualDecidableType. + +(** a [UsualDecidableType] is in particular an [DecidableType]. *) + +Module UDT_to_DT (U:UsualDecidableType) <: DecidableType := U. + +(** an shortcut for easily building a UsualDecidableType *) + +Module Type MiniDecidableType. + Parameter Inline t : Type. + Parameter eq_dec : forall x y:t, { x=y }+{ x<>y }. +End MiniDecidableType. + +Module Make_UDT (M:MiniDecidableType) <: UsualDecidableType. + Definition t:=M.t. + Definition eq := @eq t. + Program Instance eq_equiv : Equivalence eq. + Definition eq_dec := M.eq_dec. +End Make_UDT. + +(** From two decidable types, we can build a new DecidableType + over their cartesian product. *) + +Module PairDecidableType(D1 D2:DecidableType) <: DecidableType. + + Definition t := prod D1.t D2.t. + + Definition eq x y := D1.eq (fst x) (fst y) /\ D2.eq (snd x) (snd y). + + Instance eq_equiv : Equivalence eq. + Proof. + constructor. + intros (x1,x2); red; simpl; auto. + intros (x1,x2) (y1,y2); unfold eq; simpl; intuition. + intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto. + Qed. + + Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. + Proof. + intros (x1,x2) (y1,y2); unfold eq; simpl. + destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); intuition. + Defined. + +End PairDecidableType. + +(** Similarly for pairs of UsualDecidableType *) + +Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType. + Definition t := prod D1.t D2.t. + Definition eq := @eq t. + Program Instance eq_equiv : Equivalence eq. + Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }. + Proof. + intros (x1,x2) (y1,y2); + destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2); + unfold eq, D1.eq, D2.eq in *; simpl; + (left; f_equal; auto; fail) || + (right; intro H; injection H; auto). + Defined. + +End PairUsualDecidableType. diff --git a/theories/Logic/DecidableTypeEx.v b/theories/Structures/DecidableTypeEx.v index 022102f70d..022102f70d 100644 --- a/theories/Logic/DecidableTypeEx.v +++ b/theories/Structures/DecidableTypeEx.v diff --git a/theories/FSets/OrderedType.v b/theories/Structures/OrderedType.v index f17eb43a95..f17eb43a95 100644 --- a/theories/FSets/OrderedType.v +++ b/theories/Structures/OrderedType.v diff --git a/theories/Structures/OrderedType2.v b/theories/Structures/OrderedType2.v new file mode 100644 index 0000000000..e1b7f4e22c --- /dev/null +++ b/theories/Structures/OrderedType2.v @@ -0,0 +1,680 @@ +(***********************************************************************) +(* 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$ *) + +Require Export SetoidList2 DecidableType2. +Set Implicit Arguments. +Unset Strict Implicit. + +(** * Ordered types *) + +Definition Cmp (A:Type)(eq lt : relation A) c := + match c with + | Eq => eq + | Lt => lt + | Gt => flip lt + end. + +Module Type MiniOrderedType. + Include Type EqualityType. + + Parameter Inline lt : t -> t -> Prop. + Instance lt_strorder : StrictOrder lt. + Instance lt_compat : Proper (eq==>eq==>iff) lt. + + Parameter compare : t -> t -> comparison. + Axiom compare_spec : forall x y, Cmp eq lt (compare x y) x y. + +End MiniOrderedType. + +Module Type OrderedType. + Include Type MiniOrderedType. + + (** A [eq_dec] can be deduced from [compare] below. But adding this + redundant field allows to see an OrderedType as a DecidableType. *) + Parameter eq_dec : forall x y, { eq x y } + { ~ eq x y }. + +End OrderedType. + +Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. + Include O. + + Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. + Proof. + intros. + generalize (compare_spec x y); destruct (compare x y); + unfold Cmp, flip; intros. + left; auto. + right. intro H'; rewrite <- H' in H. + apply (StrictOrder_Irreflexive x); auto. + right. intro H'; rewrite <- H' in H. + apply (StrictOrder_Irreflexive x); auto. + Defined. + +End MOT_to_OT. + +(** * Ordered types properties *) + +(** Additional properties that can be derived from signature + [OrderedType]. *) + +Module OrderedTypeFacts (Import O: OrderedType). + + Infix "==" := eq (at level 70, no associativity) : order. + Infix "<" := lt : order. + Notation "x <= y" := (~lt y x) : order. + Infix "?=" := compare (at level 70, no associativity) : order. + + Local Open Scope order. + + (** The following lemmas are re-phrasing of eq_equiv and lt_strorder. + Interest: compatibility, simple use (e.g. in tactic order), etc. *) + + Definition eq_refl (x:t) : x==x := Equivalence_Reflexive x. + + Definition eq_sym (x y:t) : x==y -> y==x := Equivalence_Symmetric x y. + + Definition eq_trans (x y z:t) : x==y -> y==z -> x==z := + Equivalence_Transitive x y z. + + Definition lt_trans (x y z:t) : x<y -> y<z -> x<z := + StrictOrder_Transitive x y z. + + Definition lt_antirefl (x:t) : ~x<x := StrictOrder_Irreflexive x. + + Lemma lt_not_eq : forall x y, x<y -> ~x==y. + Proof. + intros x y H H'. rewrite H' in H. + apply lt_antirefl with y; auto. + Qed. + + Lemma lt_eq : forall x y z, x<y -> y==z -> x<z. + Proof. + intros x y z H H'. rewrite <- H'; auto. + Qed. + + Lemma eq_lt : forall x y z, x==y -> y<z -> x<z. + Proof. + intros x y z H H'. rewrite H; auto. + Qed. + + Lemma le_eq : forall x y z, x<=y -> y==z -> x<=z. + Proof. + intros x y z H H' H''. rewrite H' in H; auto. + Qed. + + Lemma eq_le : forall x y z, x==y -> y<=z -> x<=z. + Proof. + intros x y z H H'. rewrite H; auto. + Qed. + + Lemma neq_eq : forall x y z, ~x==y -> y==z -> ~x==z. + Proof. + intros x y z H H'; rewrite <-H'; auto. + Qed. + + Lemma eq_neq : forall x y z, x==y -> ~y==z -> ~x==z. + Proof. + intros x y z H H'; rewrite H; auto. + Qed. + + Hint Resolve eq_trans eq_refl lt_trans. + Hint Immediate eq_sym eq_lt lt_eq le_eq eq_le neq_eq eq_neq. + + Ltac elim_compare x y := + generalize (compare_spec x y); destruct (compare x y); + unfold Cmp, flip. + + Lemma le_lt_trans : forall x y z, x<=y -> y<z -> x<z. + Proof. + intros. elim_compare x y; intro H'. + rewrite H'; auto. + transitivity y; auto. + intuition. + Qed. + + Lemma lt_le_trans : forall x y z, x<y -> y<=z -> x<z. + Proof. + intros. elim_compare y z; intro H'. + rewrite <- H'; auto. + transitivity y; auto. + intuition. + Qed. + + Lemma le_trans : forall x y z, x<=y -> y<=z -> x<=z. + Proof. + intros x y z Hxy Hyz Hzx. + apply Hxy. + eapply le_lt_trans; eauto. + Qed. + + Lemma le_antisym : forall x y, x<=y -> y<=x -> x==y. + Proof. + intros. elim_compare x y; intuition. + Qed. + + Lemma le_neq : forall x y, x<=y -> ~x==y -> x<y. + Proof. + intros. elim_compare x y; intuition. + Qed. + + Lemma neq_sym : forall x y, ~x==y -> ~y==x. + Proof. + intuition. + Qed. + +(** The order tactic *) + +(** This tactic is designed to solve systems of (in)equations + involving eq and lt and ~eq and ~lt (i.e. ge). All others + parts of the goal will be discarded. This tactic is + domain-agnostic : it will only use equivalence+order axioms. + Moreover it doesn't directly use totality of the order + (but uses above lemmas such as le_trans that rely on it). + A typical use of this tactic is transitivity problems. *) + +Definition hide_eq := eq. + +(** order_eq : replace x by y in all (in)equations thanks + to equality EQ (where eq has been hidden in order to avoid + self-rewriting). + + NB: order_saturate_eq could be written in a shorter way thanks + to rewrite, but proof terms would be uglier *) + +Ltac order_eq x y EQ := + let rewr H t := generalize t; clear H; intro H + in + match goal with + | H : x == _ |- _ => rewr H (eq_trans (eq_sym EQ) H); order_eq x y EQ + | H : _ == x |- _ => rewr H (eq_trans H EQ); order_eq x y EQ + | H : ~x == _ |- _ => rewr H (eq_neq (eq_sym EQ) H); order_eq x y EQ + | H : ~_ == x |- _ => rewr H (neq_eq H EQ); order_eq x y EQ + | H : x < ?z |- _ => rewr H (eq_lt (eq_sym EQ) H); order_eq x y EQ + | H : ?z < x |- _ => rewr H (lt_eq H EQ); order_eq x y EQ + | H : x <= ?z |- _ => rewr H (eq_le (eq_sym EQ) H); order_eq x y EQ + | H : ?z <= x |- _ => rewr H (le_eq H EQ); order_eq x y EQ + (* NB: no negation in the goal, see below *) + | |- x == ?z => apply eq_trans with y; [apply EQ| ]; order_eq x y EQ + | |- ?z == x => apply eq_trans with y; [ | apply (eq_sym EQ) ]; + order_eq x y EQ + | |- x < ?z => apply eq_lt with y; [apply EQ| ]; order_eq x y EQ + | |- ?z < x => apply lt_eq with y; [ | apply (eq_sym EQ) ]; + order_eq x y EQ + | _ => clear EQ +end. + +Ltac order := intros; trivial; + match goal with + | |- ~ _ => intro; order + | H : ?A -> False |- _ => change (~A) in H; order + (* First, successful situations *) + | H : ?x < ?x |- _ => elim (lt_antirefl H) + | H : ~ ?x == ?x |- _ => elim (H (Equivalence_Reflexive x)) + | |- ?x == ?x => apply (Equivalence_Reflexive x) + (* Second, useless hyps or goal *) + | H : ?x == ?x |- _ => clear H; order + | H : ?x <= ?x |- _ => clear H; order + | |- ?x < ?x => elimtype False; order + (* We eliminate equalities *) + | H : ?x == ?y |- _ => + change (hide_eq x y) in H; order_eq x y H; order + (* Simultaneous le and ge is eq *) + | H1 : ?x <= ?y, H2 : ?y <= ?x |- _ => + generalize (le_antisym H1 H2); clear H1 H2; intro; order + (* Simultaneous le and ~eq is lt *) + | H1: ?x <= ?y, H2: ~ ?x == ?y |- _ => + generalize (le_neq H1 H2); clear H1 H2; intro; order + | H1: ?x <= ?y, H2: ~ ?y == ?x |- _ => + generalize (le_neq H1 (neq_sym H2)); clear H1 H2; intro; order + (* Transitivity of lt and le *) + | H1 : ?x < ?y, H2 : ?y < ?z |- _ => + match goal with + | H : x < z |- _ => fail 1 + | _ => generalize (lt_trans H1 H2); intro; order + end + | H1 : ?x <= ?y, H2 : ?y < ?z |- _ => + match goal with + | H : x < z |- _ => fail 1 + | _ => generalize (le_lt_trans H1 H2); intro; order + end + | H1 : ?x < ?y, H2 : ?y <= ?z |- _ => + match goal with + | H : x < z |- _ => fail 1 + | _ => generalize (lt_le_trans H1 H2); intro; order + end + | H1 : ?x <= ?y, H2 : ?y <= ?z |- _ => + match goal with + | H : x <= z |- _ => fail 1 + | _ => generalize (le_trans H1 H2); intro; order + end + | _ => auto; fail +end. + +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 compare_eq_iff : forall x y, (x ?= y) = Eq <-> x==y. + Proof. + intros; elim_compare x y; intuition; try discriminate; order. + Qed. + + Lemma compare_lt_iff : forall x y, (x ?= y) = Lt <-> x<y. + Proof. + intros; elim_compare x y; intuition; try discriminate; order. + Qed. + + Lemma compare_gt_iff : forall x y, (x ?= y) = Gt <-> y<x. + Proof. + intros; elim_compare x y; intuition; try discriminate; order. + Qed. + + Lemma compare_ge_iff : forall x y, (x ?= y) <> Lt <-> y<=x. + Proof. + intros; rewrite compare_lt_iff; intuition. + Qed. + + Lemma compare_le_iff : forall x y, (x ?= y) <> Gt <-> x<=y. + Proof. + intros; rewrite compare_gt_iff; intuition. + Qed. + + Hint Rewrite compare_eq_iff compare_lt_iff compare_gt_iff : order. + + Instance compare_compat : Proper (eq==>eq==>Logic.eq) compare. + Proof. + intros x x' Hxx' y y' Hyy'. + elim_compare x' y'; intros; autorewrite with order; order. + Qed. + + Lemma compare_refl : forall x, (x ?= x) = Eq. + Proof. + intros; elim_compare x x; auto; order. + Qed. + + Lemma compare_antisym : forall x y, (y ?= x) = CompOpp (x ?= y). + Proof. + intros; elim_compare x y; simpl; intros; autorewrite with order; order. + Qed. + + (** For compatibility reasons *) + Definition eq_dec := eq_dec. + + Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. + Proof. + intros; elim_compare x y; [ right | left | right ]; auto. + Defined. + + Definition eqb x y : bool := if eq_dec x y then true else false. + + Lemma if_eq_dec : forall x y (B:Type)(b b':B), + (if eq_dec x y then b else b') = + (match compare x y with Eq => b | _ => b' end). + Proof. + intros; destruct eq_dec; elim_compare x y; auto; order. + Qed. + + Lemma eqb_alt : + forall x y, eqb x y = match compare x y with Eq => true | _ => false end. + Proof. + unfold eqb; intros; apply if_eq_dec. + Qed. + + Instance eqb_compat : Proper (eq==>eq==>Logic.eq) eqb. + Proof. + intros x x' Hxx' y y' Hyy'. + rewrite 2 eqb_alt, Hxx', Hyy'; auto. + Qed. + + +(* Specialization of resuts about lists modulo. *) + +Section ForNotations. + +Notation In:=(InA eq). +Notation Inf:=(lelistA lt). +Notation Sort:=(sort lt). +Notation NoDup:=(NoDupA eq). + +Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. +Proof. intros. rewrite <- H; auto. Qed. + +Lemma ListIn_In : forall l x, List.In x l -> In x l. +Proof. exact (In_InA eq_equiv). Qed. + +Lemma Inf_lt : forall l x y, lt x y -> Inf y l -> Inf x l. +Proof. exact (InfA_ltA lt_strorder). Qed. + +Lemma Inf_eq : forall l x y, eq x y -> Inf y l -> Inf x l. +Proof. exact (InfA_eqA eq_equiv lt_strorder lt_compat). Qed. + +Lemma Sort_Inf_In : forall l x a, Sort l -> Inf a l -> In x l -> lt a x. +Proof. exact (SortA_InfA_InA eq_equiv lt_strorder lt_compat). Qed. + +Lemma 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_equiv (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_equiv lt_strorder lt_compat). Qed. + +Lemma Sort_NoDup : forall l, Sort l -> NoDup l. +Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat) . Qed. + +End ForNotations. + +Hint Resolve ListIn_In Sort_NoDup Inf_lt. +Hint Immediate In_eq Inf_lt. + +End OrderedTypeFacts. + +Definition ProdRel {A B}(RA:relation A)(RB:relation B) : relation (A*B) := + fun p p' => RA (fst p) (fst p') /\ RB (snd p) (snd p'). + +Definition FstRel {A B}(R:relation A) : relation (A*B) := + fun p p' => R (fst p) (fst p'). + +Definition SndRel {A B}(R:relation B) : relation (A*B) := + fun p p' => R (snd p) (snd p'). + +Instance ProdRel_equiv {A B} `(Equivalence A RA)`(Equivalence B RB) : + Equivalence (ProdRel RA RB). +Proof. firstorder. Qed. + +Instance FstRel_equiv {A B} `(Equivalence A RA) : + Equivalence (FstRel RA (B:=B)). +Proof. firstorder. Qed. + +Instance SndRel_equiv {A B} `(Equivalence B RB) : + Equivalence (SndRel RB (A:=A)). +Proof. firstorder. Qed. + +Instance FstRel_strorder {A B} `(StrictOrder A RA) : + StrictOrder (FstRel RA (B:=B)). +Proof. firstorder. Qed. + +Instance SndRel_strorder {A B} `(StrictOrder B RB) : + StrictOrder (SndRel RB (A:=A)). +Proof. firstorder. Qed. + +Lemma FstRel_ProdRel {A B}(RA:relation A) : forall p p':A*B, + (FstRel RA) p p' <-> (ProdRel RA (fun _ _ =>True)) p p'. +Proof. firstorder. Qed. + +Lemma SndRel_ProdRel {A B}(RB:relation B) : forall p p':A*B, + (SndRel RB) p p' <-> (ProdRel (fun _ _ =>True) RB) p p'. +Proof. firstorder. Qed. + +Lemma ProdRel_alt {A B}(RA:relation A)(RB:relation B) : forall p p':A*B, + (ProdRel RA RB) p p' <-> relation_conjunction (FstRel RA) (SndRel RB) p p'. +Proof. firstorder. Qed. + +Instance FstRel_compat {A B} (R : relation A)`(Proper _ (Ri==>Ri==>Ro) R) : + Proper (FstRel Ri==>FstRel Ri==>Ro) (FstRel R (B:=B)). +Proof. + intros A B R Ri Ro H (a1,b1) (a1',b1') Hab1 (a2,b2) (a2',b2') Hab2. + unfold FstRel in *; simpl in *. apply H; auto. +Qed. + +Instance SndRel_compat {A B} (R : relation B)`(Proper _ (Ri==>Ri==>Ro) R) : + Proper (SndRel Ri==>SndRel Ri==>Ro) (SndRel R (A:=A)). +Proof. + intros A B R Ri Ro H (a1,b1) (a1',b1') Hab1 (a2,b2) (a2',b2') Hab2. + unfold SndRel in *; simpl in *. apply H; auto. +Qed. + +Instance FstRel_sub {A B} (RA:relation A)(RB:relation B): + subrelation (ProdRel RA RB) (FstRel RA). +Proof. firstorder. Qed. + +Instance SndRel_sub {A B} (RA:relation A)(RB:relation B): + subrelation (ProdRel RA RB) (SndRel RB). +Proof. firstorder. Qed. + +Instance pair_compat { A B } (RA:relation A)(RB : relation B) : + Proper (RA==>RB==>ProdRel RA RB) (@pair A B). +Proof. firstorder. Qed. + + +Hint Unfold ProdRel FstRel SndRel. +Hint Extern 2 (ProdRel _ _ _ _) => split. + + +Module KeyOrderedType(Import O:OrderedType). + Module Import MO:=OrderedTypeFacts(O). + + Section Elt. + Variable elt : Type. + Notation key:=t. + + Definition eqk : relation (key*elt) := FstRel eq. + Definition eqke : relation (key*elt) := ProdRel eq Logic.eq. + Definition ltk : relation (key*elt) := FstRel lt. + + Hint Unfold eqk eqke ltk. + + (* eqke is stricter than eqk *) + + Global Instance eqke_eqk : subrelation eqke eqk. + Proof. unfold eqke, eqk; auto with *. 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 *) + + Global Instance eqk_equiv : Equivalence eqk. + + Global Instance eqke_equiv : Equivalence eqke. + + Global Instance ltk_strorder : StrictOrder ltk. + + Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. + Proof. unfold eqk, ltk; auto with *. Qed. + + (* Additionnal facts *) + + Global Instance pair_compat : Proper (eq==>Logic.eq==>eqke) (@pair key elt). + Proof. unfold eqke; auto with *. Qed. + + Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. + Proof. + intros e e' LT EQ; rewrite EQ in LT. + elim (StrictOrder_Irreflexive _ LT). + Qed. + + Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. + Proof. + intros e e' LT EQ; rewrite EQ in LT. + elim (StrictOrder_Irreflexive _ LT). + Qed. + + Lemma InA_eqke_eqk : + forall x m, InA eqke x m -> InA eqk x m. + Proof. + unfold eqke, ProdRel; 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; compute in H. + exists e; auto. + destruct IHInA as [e H0]. + exists e; auto. + Qed. + + Lemma In_alt2 : forall k l, In k l <-> ExistsL (fun p => eq k (fst p)) l. + Proof. + unfold In, MapsTo. + setoid_rewrite ExistsL_exists; setoid_rewrite InA_alt. + firstorder. + exists (snd x), x; auto. + Qed. + + Lemma In_nil : forall k, In k nil <-> False. + Proof. + intros; rewrite In_alt2; apply ExistsL_nil. + Qed. + + Lemma In_cons : forall k p l, + In k (p::l) <-> eq k (fst p) \/ In k l. + Proof. + intros; rewrite !In_alt2, ExistsL_cons; intuition. + Qed. + + Global Instance MapsTo_compat : + Proper (eq==>Logic.eq==>equivlistA eqke==>iff) MapsTo. + Proof. + intros x x' Hx e e' He l l' Hl. unfold MapsTo. + rewrite Hx, He, Hl; intuition. + Qed. + + Global Instance In_compat : Proper (eq==>equivlistA eqk==>iff) In. + Proof. + intros x x' Hx l l' Hl. rewrite !In_alt. + setoid_rewrite Hl. setoid_rewrite Hx. intuition. + Qed. + + Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. + Proof. intros l x y e EQ. rewrite <- EQ; auto. Qed. + + Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. + Proof. intros l x y EQ. rewrite <- EQ; auto. Qed. + + Lemma Inf_eq : forall l x x', eqk x x' -> Inf x' l -> Inf x l. + Proof. intros l x x' H. rewrite H; auto. Qed. + + Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. + Proof. apply InfA_ltA; auto with *. Qed. + + Hint Immediate Inf_eq. + Hint Resolve Inf_lt. + + Lemma Sort_Inf_In : + forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. + Proof. apply SortA_InfA_InA; auto with *. Qed. + + Lemma Sort_Inf_NotIn : + forall l k e, Sort l -> Inf (k,e) l -> ~In k l. + 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. apply SortA_NoDupA; auto with *. Qed. + + Lemma Sort_In_cons_1 : forall e l e', Sort (e::l) -> InA eqk e' l -> ltk e e'. + Proof. + intros; invlist sort; eapply Sort_Inf_In; eauto. + Qed. + + Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> + ltk e e' \/ eqk e e'. + Proof. + intros; invlist InA; 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. + intros; invlist sort; red; intros. + eapply Sort_Inf_NotIn; eauto using In_eq. + Qed. + + Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. + Proof. + intros; invlist In; invlist MapsTo. compute in * |- ; intuition. + right; exists x; auto. + Qed. + + Lemma In_inv_2 : forall k k' e e' l, + InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. + Proof. + intros; invlist InA; intuition. + Qed. + + Lemma In_inv_3 : forall x x' l, + InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. + Proof. + intros; invlist InA; compute in * |- ; intuition. + Qed. + + End Elt. + + Hint Resolve (fun elt => @Equivalence_Reflexive _ _ (eqk_equiv elt)). + Hint Resolve (fun elt => @Equivalence_Transitive _ _ (eqk_equiv elt)). + Hint Immediate (fun elt => @Equivalence_Symmetric _ _ (eqk_equiv elt)). + Hint Resolve (fun elt => @Equivalence_Reflexive _ _ (eqke_equiv elt)). + Hint Resolve (fun elt => @Equivalence_Transitive _ _ (eqke_equiv elt)). + Hint Immediate (fun elt => @Equivalence_Symmetric _ _ (eqke_equiv elt)). + Hint Resolve (fun elt => @StrictOrder_Transitive _ _ (ltk_strorder elt)). + + Hint Unfold eqk eqke ltk. + Hint Extern 2 (eqke ?a ?b) => split. + Hint Resolve ltk_not_eqk ltk_not_eqke. + Hint Resolve InA_eqke_eqk. + Hint Unfold MapsTo In. + Hint Immediate Inf_eq. + Hint Resolve Inf_lt. + Hint Resolve Sort_Inf_NotIn. + Hint Resolve In_inv_2 In_inv_3. + +End KeyOrderedType. diff --git a/theories/Structures/OrderedType2Alt.v b/theories/Structures/OrderedType2Alt.v new file mode 100644 index 0000000000..43b3d05f8a --- /dev/null +++ b/theories/Structures/OrderedType2Alt.v @@ -0,0 +1,297 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* Finite sets library. + * Authors: Pierre Letouzey and Jean-Christophe Filliâtre + * Institution: LRI, CNRS UMR 8623 - Université Paris Sud + * 91405 Orsay, France *) + +(* $Id$ *) + +Require Import OrderedType2. +Set Implicit Arguments. + +(** NB: Instead of [comparison], defined in [Datatypes.v] which is [Eq|Lt|Gt], + we used historically the dependent type [compare] which is + [EQ _ | LT _ | GT _ ] +*) + +Inductive Compare (X : Type) (lt eq : X -> X -> Prop) (x y : X) : Type := + | LT : lt x y -> Compare lt eq x y + | EQ : eq x y -> Compare lt eq x y + | GT : lt y x -> Compare lt eq x y. + +(** * Some alternative (but equivalent) presentations for an Ordered Type + inferface. *) + +(** ** The original interface *) + +Module Type OrderedTypeOrig. + Parameter Inline t : Type. + + Parameter Inline 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 Inline lt : t -> t -> Prop. + 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. + +End OrderedTypeOrig. + +(** ** An interface based on compare *) + +Module Type OrderedTypeAlt. + + Parameter t : Type. + + Parameter compare : t -> t -> comparison. + + Infix "?=" := compare (at level 70, no associativity). + + Parameter compare_sym : + forall x y, (y?=x) = CompOpp (x?=y). + Parameter compare_trans : + forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. + +End OrderedTypeAlt. + +(** ** From OrderedTypeOrig to OrderedType. *) + +Module OrderedType_from_Orig (O:OrderedTypeOrig) <: OrderedType. + + Import O. + Definition t := O.t. + Definition eq := O.eq. + Instance eq_equiv : Equivalence eq. + Proof. + split; red; [ apply eq_refl | apply eq_sym | eapply eq_trans ]. + Qed. + + Definition lt := O.lt. + Instance lt_strorder : StrictOrder lt. + Proof. + split; repeat red; intros. + eapply lt_not_eq; eauto. + eapply lt_trans; eauto. + 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 x y); eauto. + elim (@lt_not_eq z y); eauto using lt_trans. + 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 y z); eauto. + elim (@lt_not_eq y x); eauto using lt_trans. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + repeat red; intros. + eapply lt_eq; eauto. eapply eq_lt; eauto. symmetry; auto. + Qed. + + Definition compare x y := + match O.compare x y with + | EQ _ => Eq + | LT _ => Lt + | GT _ => Gt + end. + + Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y. + Proof. + intros; unfold compare; destruct O.compare; auto. + Qed. + + Definition eq_dec : forall x y, { eq x y } + { ~eq x y }. + Proof. + intros; destruct (O.compare x y). + right. apply lt_not_eq; auto. + left; auto. + right. intro. apply (@lt_not_eq y x); auto. + Defined. + +End OrderedType_from_Orig. + +(** ** From OrderedType to OrderedTypeOrig. *) + +Module OrderedType_to_Orig (O:OrderedType) <: OrderedTypeOrig. + + Import O. + Definition t := t. + Definition eq := eq. + Definition lt := lt. + + Lemma eq_refl : Reflexive eq. + Proof. auto. Qed. + Lemma eq_sym : Symmetric eq. + Proof. apply eq_equiv. Qed. + Lemma eq_trans : Transitive eq. + Proof. apply eq_equiv. Qed. + + Lemma lt_not_eq : forall x y, lt x y -> ~eq x y. + Proof. + intros x y L E; rewrite E in L. apply (StrictOrder_Irreflexive y); auto. + Qed. + + Lemma lt_trans : Transitive lt. + Proof. apply lt_strorder. Qed. + + Definition compare : forall x y, Compare lt eq x y. + Proof. + intros. generalize (compare_spec x y); unfold Cmp, flip. + destruct (compare x y); [apply EQ|apply LT|apply GT]; auto. + Defined. + + Definition eq_dec := eq_dec. + +End OrderedType_to_Orig. + + +(** ** From OrderedTypeAlt to OrderedType. *) + +Module OrderedType_from_Alt (O:OrderedTypeAlt) <: OrderedType. + Import O. + + Definition t := t. + + Definition eq x y := (x?=y) = Eq. + Definition lt x y := (x?=y) = Lt. + + Instance eq_equiv : Equivalence eq. + Proof. + split; red. + (* refl *) + unfold eq; intros x. + assert (H:=compare_sym x x). + destruct (x ?= x); simpl in *; auto; discriminate. + (* sym *) + unfold eq; intros x y H. + rewrite compare_sym, H; simpl; auto. + (* trans *) + apply compare_trans. + Qed. + + Instance lt_strorder : StrictOrder lt. + Proof. + split; repeat red; unfold lt; try apply compare_trans. + intros x H. + assert (eq x x) by reflexivity. + unfold eq in *; congruence. + Qed. + + Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. + Proof. + unfold lt, eq; intros x y z Hxy Hyz. + destruct (compare x z) as [ ]_eqn:Hxz; auto. + rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz. + rewrite (compare_trans Hxz Hyz) in Hxy; discriminate. + rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy. + rewrite (compare_trans Hxy Hxz) in Hyz; discriminate. + Qed. + + Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. + Proof. + unfold lt, eq; intros x y z Hxy Hyz. + destruct (compare x z) as [ ]_eqn:Hxz; auto. + rewrite compare_sym, CompOpp_iff in Hxy. simpl in Hxy. + rewrite (compare_trans Hxy Hxz) in Hyz; discriminate. + rewrite compare_sym, CompOpp_iff in Hyz. simpl in Hyz. + rewrite (compare_trans Hxz Hyz) in Hxy; discriminate. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + apply proper_sym_impl_iff_2; auto with *. + repeat red; intros. + eapply lt_eq; eauto. eapply eq_lt; eauto. symmetry; auto. + Qed. + + Definition compare := O.compare. + + Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y. + Proof. + unfold Cmp, flip, eq, lt, compare; intros. + destruct (O.compare x y) as [ ]_eqn:H; auto. + rewrite compare_sym, H; auto. + Qed. + + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros; unfold eq. + case (x ?= y); [ left | right | right ]; auto; discriminate. + Defined. + +End OrderedType_from_Alt. + +(** From the original presentation to this alternative one. *) + +Module OrderedType_to_Alt (O:OrderedType) <: OrderedTypeAlt. + Import O. + + Definition t := t. + Definition compare := compare. + + Infix "?=" := compare (at level 70, no associativity). + + Lemma compare_sym : + forall x y, (y?=x) = CompOpp (x?=y). + Proof. + intros x y; unfold compare. + generalize (compare_spec x y) (compare_spec y x); unfold Cmp, flip. + destruct (O.compare x y); destruct (O.compare y x); intros U V; auto. + rewrite U in V. elim (StrictOrder_Irreflexive y); auto. + rewrite U in V. elim (StrictOrder_Irreflexive y); auto. + rewrite V in U. elim (StrictOrder_Irreflexive x); auto. + rewrite V in U. elim (StrictOrder_Irreflexive x); auto. + rewrite V in U. elim (StrictOrder_Irreflexive x); auto. + rewrite V in U. elim (StrictOrder_Irreflexive y); auto. + Qed. + + Lemma compare_Eq : forall x y, compare x y = Eq <-> eq x y. + Proof. + unfold compare. + intros x y; generalize (compare_spec x y). + destruct (O.compare x y); intuition; try discriminate. + rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto. + rewrite H0 in H. elim (StrictOrder_Irreflexive y); auto. + Qed. + + Lemma compare_Lt : forall x y, compare x y = Lt <-> lt x y. + Proof. + unfold compare. + intros x y; generalize (compare_spec x y); unfold Cmp, flip. + destruct (O.compare x y); intuition; try discriminate. + rewrite H in H0. elim (StrictOrder_Irreflexive y); auto. + rewrite H in H0. elim (StrictOrder_Irreflexive x); auto. + Qed. + + Lemma compare_trans : + forall c x y z, (x?=y) = c -> (y?=z) = c -> (x?=z) = c. + Proof. + intros c x y z. + destruct c; unfold compare. + rewrite 3 compare_Eq; eauto. + rewrite 3 compare_Lt. apply StrictOrder_Transitive. + do 3 (rewrite compare_sym, CompOpp_iff, compare_Lt). + intros; apply StrictOrder_Transitive with y; auto. + Qed. + +End OrderedType_to_Alt. diff --git a/theories/Structures/OrderedType2Ex.v b/theories/Structures/OrderedType2Ex.v new file mode 100644 index 0000000000..73bd3810f9 --- /dev/null +++ b/theories/Structures/OrderedType2Ex.v @@ -0,0 +1,261 @@ +(***********************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA-Rocquencourt & LRI-CNRS-Orsay *) +(* \VV/ *************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(***********************************************************************) + +(* Finite sets library. + * Authors: Pierre Letouzey and Jean-Christophe Filliâtre + * Institution: LRI, CNRS UMR 8623 - Université Paris Sud + * 91405 Orsay, France *) + +(* $Id$ *) + +Require Import OrderedType2 DecidableType2Ex. +Require Import ZArith NArith Ndec Compare_dec. + +(** * Examples of Ordered Type structures. *) + +(** First, a particular case of [OrderedType] where + the equality is the usual one of Coq. *) + +Module Type UsualOrderedType. + Include Type UsualDecidableType. + + Parameter Inline lt : t -> t -> Prop. + Instance lt_strorder : StrictOrder lt. + (* The following is useless since eq is Leibniz, but should be there + for subtyping... *) + Instance lt_compat : Proper (eq==>eq==>iff) lt. + + Parameter compare : t -> t -> comparison. + Axiom compare_spec : forall x y, Cmp eq lt (compare x y) x y. + +End UsualOrderedType. + +(** a [UsualOrderedType] is in particular an [OrderedType]. *) + +Module UOT_to_OT (U:UsualOrderedType) <: OrderedType := U. + +(** [nat] is an ordered type with respect to the usual order on natural numbers. *) + +Module Nat_as_OT <: UsualOrderedType. + + Definition t := nat. + Definition eq := @eq nat. + Definition lt := lt. + Definition compare := nat_compare. + Definition eq_dec := eq_nat_dec. + + Program Instance eq_equiv : Equivalence eq. + + Instance lt_strorder : StrictOrder lt. + Proof. + constructor; [exact lt_irrefl|exact lt_trans]. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + unfold eq in *; repeat red; intros; subst; auto. + Qed. + + Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y. + Proof. + intros. + unfold Cmp, flip, lt, eq. destruct (compare x y) as [ ]_eqn:H. + apply nat_compare_eq; auto. + apply nat_compare_Lt_lt; auto. + apply nat_compare_Gt_gt; auto. + Qed. + +End Nat_as_OT. + + +(** [Z] is an ordered type with respect to the usual order on integers. *) + +Module Z_as_OT <: UsualOrderedType. + + Definition t := Z. + Definition eq := @eq Z. + Definition lt := Zlt. + Definition compare := Zcompare. + Definition eq_dec := Z_eq_dec. + + Program Instance eq_equiv : Equivalence eq. + + Instance lt_strorder : StrictOrder lt. + Proof. + constructor; [exact Zlt_irrefl | exact Zlt_trans]. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + unfold eq in *; repeat red; intros; subst; auto. + Qed. + + Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y. + Proof. + intros. + unfold Cmp, flip, lt, eq. destruct (compare x y) as [ ]_eqn:H. + apply Zcompare_Eq_eq; auto. + auto. + apply Zgt_lt; auto. + Qed. + +End Z_as_OT. + +(** [positive] is an ordered type with respect to the usual order + on natural numbers. *) + +Module Positive_as_OT <: UsualOrderedType. + Definition t:=positive. + Definition eq:=@eq positive. + Definition lt:=Plt. + Definition compare x y := Pcompare x y Eq. + + Program Instance eq_equiv : Equivalence eq. + + Instance lt_strorder : StrictOrder lt. + Proof. + constructor; [exact Plt_irrefl | exact Plt_trans]. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + unfold eq in *; repeat red; intros; subst; auto. + Qed. + + Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y. + Proof. + intros. + unfold Cmp, flip, lt, eq. destruct (compare x y) as [ ]_eqn:H. + apply Pcompare_Eq_eq; auto. + auto. + apply ZC1; auto. + Qed. + + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros; unfold eq; decide equality. + Defined. + +End Positive_as_OT. + + +(** [N] is an ordered type with respect to the usual order + on natural numbers. *) + +Module N_as_OT <: UsualOrderedType. + Definition t:=N. + Definition eq:=@eq N. + Definition lt:=Nlt. + Definition compare:=Ncompare. + + Program Instance eq_equiv : Equivalence eq. + + Instance lt_strorder : StrictOrder lt. + Proof. + constructor; [exact Nlt_irrefl | exact Nlt_trans]. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + unfold eq in *; repeat red; intros; subst; auto. + Qed. + + Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y. + Proof. + intros. + unfold Cmp, flip, lt, eq. destruct (compare x y) as [ ]_eqn:H. + apply Ncompare_Eq_eq; auto. + auto. + apply Ngt_Nlt; auto. + Qed. + + Definition eq_dec : forall x y, { eq x y } + { ~ eq x y }. + Proof. + intros. unfold eq. decide equality. apply Positive_as_OT.eq_dec. + Defined. + +End N_as_OT. + + +(** An OrderedType can now directly be seen as a DecidableType *) + +Module OT_as_DT (O:OrderedType) <: DecidableType := O. + +(** (Usual) Decidable Type for [nat], [positive], [N], [Z] *) + +Module Nat_as_DT <: UsualDecidableType := Nat_as_OT. +Module Positive_as_DT <: UsualDecidableType := Positive_as_OT. +Module N_as_DT <: UsualDecidableType := N_as_OT. +Module Z_as_DT <: UsualDecidableType := Z_as_OT. + + + + +(** From two ordered types, we can build a new OrderedType + over their cartesian product, using the lexicographic order. *) + +Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. + + Definition t := prod O1.t O2.t. + + Definition eq := ProdRel O1.eq O2.eq. + + Definition lt x y := + O1.lt (fst x) (fst y) \/ + (O1.eq (fst x) (fst y) /\ O2.lt (snd x) (snd y)). + + Instance eq_equiv : Equivalence eq. + + Instance lt_strorder : StrictOrder lt. + Proof. + split. + (* irreflexive *) + intros (x1,x2); compute. destruct 1. + apply (StrictOrder_Irreflexive x1); auto. + apply (StrictOrder_Irreflexive x2); intuition. + (* transitive *) + intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition. + left; etransitivity; eauto. + left; rewrite <- H0; auto. + left; rewrite H; auto. + right; split; eauto. etransitivity; eauto. + Qed. + + Instance lt_compat : Proper (eq==>eq==>iff) lt. + Proof. + intros (x1,x2) (x1',x2') (X1,X2) (y1,y2) (y1',y2') (Y1,Y2). + unfold lt; simpl in *. + rewrite X1,X2,Y1,Y2; intuition. + Qed. + + Definition compare x y := + match O1.compare (fst x) (fst y) with + | Eq => O2.compare (snd x) (snd y) + | Lt => Lt + | Gt => Gt + end. + + Lemma compare_spec : forall x y, Cmp eq lt (compare x y) x y. + Proof. + intros (x1,x2) (y1,y2); unfold Cmp, flip, compare, eq, lt; simpl. + generalize (O1.compare_spec x1 y1); destruct (O1.compare x1 y1); intros; auto. + generalize (O2.compare_spec x2 y2); destruct (O2.compare x2 y2); intros; auto. + Qed. + + Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. + Proof. + intros; generalize (compare_spec x y); destruct (compare x y). + left; auto. + right. intros E; rewrite E in *. + apply (StrictOrder_Irreflexive y); auto. + right. intros E; rewrite E in *. + apply (StrictOrder_Irreflexive y); auto. + Defined. + +End PairOrderedType. + diff --git a/theories/FSets/OrderedTypeAlt.v b/theories/Structures/OrderedTypeAlt.v index 23ae4c85a3..23ae4c85a3 100644 --- a/theories/FSets/OrderedTypeAlt.v +++ b/theories/Structures/OrderedTypeAlt.v diff --git a/theories/FSets/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v index a39f336a57..a39f336a57 100644 --- a/theories/FSets/OrderedTypeEx.v +++ b/theories/Structures/OrderedTypeEx.v diff --git a/theories/theories.itarget b/theories/theories.itarget index fc7a1eca35..320d6d41ce 100644 --- a/theories/theories.itarget +++ b/theories/theories.itarget @@ -61,9 +61,29 @@ FSets/FSetProperties.vo FSets/FSets.vo FSets/FSetToFiniteSet.vo FSets/FSetWeakList.vo -FSets/OrderedTypeAlt.vo -FSets/OrderedTypeEx.vo -FSets/OrderedType.vo + +MSets/MSetAVL.vo +MSets/MSetDecide.vo +MSets/MSetEqProperties.vo +MSets/MSetFacts.vo +MSets/MSetInterface.vo +MSets/MSetList.vo +MSets/MSetProperties.vo +MSets/MSets.vo +MSets/MSetToFiniteSet.vo +MSets/MSetWeakList.vo + +Structures/OrderedTypeAlt.vo +Structures/OrderedTypeEx.vo +Structures/OrderedType.vo +Structures/DecidableType.vo +Structures/DecidableTypeEx.vo + +Structures/OrderedType2Alt.vo +Structures/OrderedType2Ex.vo +Structures/OrderedType2.vo +Structures/DecidableType2.vo +Structures/DecidableType2Ex.vo Init/Datatypes.vo Init/Logic_Type.vo @@ -79,6 +99,7 @@ Lists/ListSet.vo Lists/ListTactics.vo Lists/List.vo Lists/SetoidList.vo +Lists/SetoidList2.vo Lists/StreamMemo.vo Lists/Streams.vo Lists/TheoryList.vo @@ -96,8 +117,6 @@ Logic/Classical_Type.vo Logic/ClassicalUniqueChoice.vo Logic/Classical.vo Logic/ConstructiveEpsilon.vo -Logic/DecidableTypeEx.vo -Logic/DecidableType.vo Logic/Decidable.vo Logic/Description.vo Logic/Diaconescu.vo diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index 4007a96bb7..d9fcdb247e 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -66,12 +66,14 @@ let theories_dirs_map = [ "theories/Unicode", "Unicode" ; "theories/Classes", "Classes" ; "theories/Program", "Program" ; + "theories/MSets", "MSets" ; "theories/FSets", "FSets" ; "theories/Reals", "Reals" ; "theories/Strings", "Strings" ; "theories/Sorting", "Sorting" ; "theories/Setoids", "Setoids" ; "theories/Sets", "Sets" ; + "theories/Structures", "Structures" ; "theories/Lists", "Lists" ; "theories/Wellfounded", "Wellfounded" ; "theories/Relations", "Relations" ; |