Commit 507a150a authored by Robbert Krebbers's avatar Robbert Krebbers

Various small changes.

* Define the standard strict order on pre orders.
* Prove that this strict order is well founded for finite sets and finite maps.
  We also provide some utilities to compute with well founded recursion.
* Improve the "simplify_option_equality" tactic to handle more cases.
* Axiomatize finiteness of finite maps by translation to lists, instead of by
  them having a finite domain.
* Prove many additional properties of finite maps.
* Add many functions and theorems on lists, including: permutations, resize,
  filter, ...
parent 50dfc148
...@@ -48,13 +48,15 @@ Hint Constructors rtc nsteps bsteps tc : ars. ...@@ -48,13 +48,15 @@ Hint Constructors rtc nsteps bsteps tc : ars.
Section rtc. Section rtc.
Context `{R : relation A}. Context `{R : relation A}.
Global Instance: Reflexive (rtc R). Instance rtc_preorder: PreOrder (rtc R).
Proof rtc_refl R. Proof.
Global Instance rtc_trans: Transitive (rtc R). split.
Proof. red; induction 1; eauto with ars. Qed. * red. apply rtc_refl.
* red. induction 1; eauto with ars.
Qed.
Lemma rtc_once x y : R x y rtc R x y. Lemma rtc_once x y : R x y rtc R x y.
Proof. eauto with ars. Qed. Proof. eauto with ars. Qed.
Global Instance: subrelation R (rtc R). Instance rtc_once_subrel: subrelation R (rtc R).
Proof. exact @rtc_once. Qed. Proof. exact @rtc_once. Qed.
Lemma rtc_r x y z : rtc R x y R y z rtc R x z. Lemma rtc_r x y z : rtc R x y R y z rtc R x z.
Proof. intros. etransitivity; eauto with ars. Qed. Proof. intros. etransitivity; eauto with ars. Qed.
...@@ -142,7 +144,7 @@ Section rtc. ...@@ -142,7 +144,7 @@ Section rtc.
Proof. intros. etransitivity; eauto with ars. Qed. Proof. intros. etransitivity; eauto with ars. Qed.
Lemma tc_rtc x y : tc R x y rtc R x y. Lemma tc_rtc x y : tc R x y rtc R x y.
Proof. induction 1; eauto with ars. Qed. Proof. induction 1; eauto with ars. Qed.
Global Instance: subrelation (tc R) (rtc R). Instance tc_once_subrel: subrelation (tc R) (rtc R).
Proof. exact @tc_rtc. Qed. Proof. exact @tc_rtc. Qed.
Lemma looping_red x : looping R x red R x. Lemma looping_red x : looping R x red R x.
...@@ -163,6 +165,14 @@ Section rtc. ...@@ -163,6 +165,14 @@ Section rtc.
Qed. Qed.
End rtc. End rtc.
(* Avoid too eager type class resolution *)
Hint Extern 5 (subrelation _ (rtc _)) =>
eapply @rtc_once_subrel : typeclass_instances.
Hint Extern 5 (subrelation _ (tc _)) =>
eapply @tc_once_subrel : typeclass_instances.
Hint Extern 5 (PreOrder (rtc _)) =>
eapply @rtc_preorder : typeclass_instances.
Hint Resolve Hint Resolve
rtc_once rtc_r rtc_once rtc_r
tc_r tc_r
...@@ -186,3 +196,35 @@ Section subrel. ...@@ -186,3 +196,35 @@ Section subrel.
Global Instance tc_subrel: subrelation (tc R1) (tc R2). Global Instance tc_subrel: subrelation (tc R1) (tc R2).
Proof. induction 1; [left|eright]; eauto; by apply Hsub. Qed. Proof. induction 1; [left|eright]; eauto; by apply Hsub. Qed.
End subrel. End subrel.
Notation wf := well_founded.
Section wf.
Context `{R : relation A}.
(** A trick by Thomas Braibant to compute with well-founded recursions:
it lazily adds [2^n] [Acc_intro] constructors in front of a well foundedness
proof, so that the actual proof is never reached in practise. *)
Fixpoint wf_guard (n : nat) (wfR : wf R) : wf R :=
match n with
| 0 => wfR
| S n => λ x, Acc_intro x (λ y _, wf_guard n (wf_guard n wfR) y)
end.
Lemma wf_projected `(R2 : relation B) (f : A B) :
( x y, R x y R2 (f x) (f y))
wf R2 wf R.
Proof.
intros Hf Hwf.
cut ( y, Acc R2 y x, y = f x Acc R x).
{ intros aux x. apply (aux (f x)); auto. }
induction 1 as [y _ IH]. intros x ?. subst.
constructor. intros. apply (IH (f y)); auto.
Qed.
End wf.
(* Generally we do not want [wf_guard] to be expanded (neither by tactics,
nor by conversion tests in the kernel), but in some cases we do need it for
computation (that is, we cannot make it opaque). We use the [Strategy]
command to make its expanding behavior less eager. *)
Strategy 100 [wf_guard].
This diff is collapsed.
...@@ -39,7 +39,7 @@ Section simple_collection. ...@@ -39,7 +39,7 @@ Section simple_collection.
Global Instance elem_of_proper: Proper ((=) ==> () ==> iff) () | 5. Global Instance elem_of_proper: Proper ((=) ==> () ==> iff) () | 5.
Proof. intros ???. subst. firstorder. Qed. Proof. intros ???. subst. firstorder. Qed.
Lemma elem_of_union_list (x : A) (Xs : list C) : Lemma elem_of_union_list (Xs : list C) (x : A) :
x Xs X, X Xs x X. x Xs X, X Xs x X.
Proof. Proof.
split. split.
...@@ -60,7 +60,7 @@ Section simple_collection. ...@@ -60,7 +60,7 @@ Section simple_collection.
Lemma not_elem_of_union x X Y : x X Y x X x Y. Lemma not_elem_of_union x X Y : x X Y x X x Y.
Proof. rewrite elem_of_union. tauto. Qed. Proof. rewrite elem_of_union. tauto. Qed.
Context `{ (X Y : C), Decision (X Y)}. Context `{ X Y : C, Decision (X Y)}.
Global Instance elem_of_dec_slow (x : A) (X : C) : Decision (x X) | 100. Global Instance elem_of_dec_slow (x : A) (X : C) : Decision (x X) | 100.
Proof. Proof.
...@@ -69,37 +69,6 @@ Section simple_collection. ...@@ -69,37 +69,6 @@ Section simple_collection.
Defined. Defined.
End simple_collection. End simple_collection.
Section collection.
Context `{Collection A C}.
Global Instance: LowerBoundedLattice C.
Proof. split. apply _. firstorder auto. Qed.
Lemma intersection_twice x : {[x]} {[x]} {[x]}.
Proof.
split; intros y; rewrite elem_of_intersection, !elem_of_singleton; tauto.
Qed.
Context `{ (X Y : C), Decision (X Y)}.
Lemma not_elem_of_intersection x X Y : x X Y x X x Y.
Proof.
rewrite elem_of_intersection.
destruct (decide (x X)); tauto.
Qed.
Lemma not_elem_of_difference x X Y : x X Y x X x Y.
Proof.
rewrite elem_of_difference.
destruct (decide (x Y)); tauto.
Qed.
Lemma union_difference X Y : X Y X X Y.
Proof.
split; intros x; rewrite !elem_of_union, elem_of_difference.
* tauto.
* destruct (decide (x X)); tauto.
Qed.
End collection.
Ltac decompose_empty := repeat Ltac decompose_empty := repeat
match goal with match goal with
| H : _ _ |- _ => apply empty_union in H; destruct H | H : _ _ |- _ => apply empty_union in H; destruct H
...@@ -116,6 +85,7 @@ Ltac unfold_elem_of := ...@@ -116,6 +85,7 @@ Ltac unfold_elem_of :=
repeat_on_hyps (fun H => repeat_on_hyps (fun H =>
repeat match type of H with repeat match type of H with
| context [ _ _ ] => setoid_rewrite elem_of_subseteq in H | context [ _ _ ] => setoid_rewrite elem_of_subseteq in H
| context [ _ _ ] => setoid_rewrite subset_spec in H
| context [ _ _ ] => setoid_rewrite elem_of_equiv_alt in H | context [ _ _ ] => setoid_rewrite elem_of_equiv_alt in H
| context [ _ ] => setoid_rewrite elem_of_empty in H | context [ _ ] => setoid_rewrite elem_of_empty in H
| context [ _ {[ _ ]} ] => setoid_rewrite elem_of_singleton in H | context [ _ {[ _ ]} ] => setoid_rewrite elem_of_singleton in H
...@@ -129,6 +99,7 @@ Ltac unfold_elem_of := ...@@ -129,6 +99,7 @@ Ltac unfold_elem_of :=
end); end);
repeat match goal with repeat match goal with
| |- context [ _ _ ] => setoid_rewrite elem_of_subseteq | |- context [ _ _ ] => setoid_rewrite elem_of_subseteq
| |- context [ _ _ ] => setoid_rewrite subset_spec
| |- context [ _ _ ] => setoid_rewrite elem_of_equiv_alt | |- context [ _ _ ] => setoid_rewrite elem_of_equiv_alt
| |- context [ _ ] => setoid_rewrite elem_of_empty | |- context [ _ ] => setoid_rewrite elem_of_empty
| |- context [ _ {[ _ ]} ] => setoid_rewrite elem_of_singleton | |- context [ _ {[ _ ]} ] => setoid_rewrite elem_of_singleton
...@@ -194,6 +165,79 @@ Tactic Notation "decompose_elem_of" hyp(H) := ...@@ -194,6 +165,79 @@ Tactic Notation "decompose_elem_of" hyp(H) :=
Tactic Notation "decompose_elem_of" := Tactic Notation "decompose_elem_of" :=
repeat_on_hyps (fun H => decompose_elem_of H). repeat_on_hyps (fun H => decompose_elem_of H).
Section collection.
Context `{Collection A C}.
Global Instance: LowerBoundedLattice C.
Proof. split. apply _. firstorder auto. Qed.
Lemma intersection_singletons x : {[x]} {[x]} {[x]}.
Proof. esolve_elem_of. Qed.
Lemma difference_twice X Y : (X Y) Y X Y.
Proof. esolve_elem_of. Qed.
Lemma empty_difference X Y : X Y X Y .
Proof. esolve_elem_of. Qed.
Lemma difference_diag X : X X .
Proof. esolve_elem_of. Qed.
Lemma difference_union_distr_l X Y Z : (X Y) Z X Z Y Z.
Proof. esolve_elem_of. Qed.
Lemma difference_intersection_distr_l X Y Z : (X Y) Z X Z Y Z.
Proof. esolve_elem_of. Qed.
Lemma elem_of_intersection_with_list (f : A A option A) Xs Y x :
x intersection_with_list f Y Xs xs y,
Forall2 () xs Xs y Y foldr (λ x, (= f x)) (Some y) xs = Some x.
Proof.
split.
* revert x. induction Xs; simpl; intros x HXs.
+ eexists [], x. intuition.
+ rewrite elem_of_intersection_with in HXs.
destruct HXs as (x1 & x2 & Hx1 & Hx2 & ?).
destruct (IHXs x2) as (xs & y & hy & ? & ?); trivial.
eexists (x1 :: xs), y. intuition (simplify_option_equality; auto).
* intros (xs & y & Hxs & ? & Hx). revert x Hx.
induction Hxs; intros; simplify_option_equality; [done |].
rewrite elem_of_intersection_with. naive_solver.
Qed.
Lemma intersection_with_list_ind (P Q : A Prop) f Xs Y :
( y, y Y P y)
Forall (λ X, x, x X Q x) Xs
( x y z, Q x P y f x y = Some z P z)
x, x intersection_with_list f Y Xs P x.
Proof.
intros HY HXs Hf.
induction Xs; simplify_option_equality; [done |].
intros x Hx. rewrite elem_of_intersection_with in Hx.
decompose_Forall. destruct Hx as (? & ? & ? & ? & ?). eauto.
Qed.
Context `{ X Y : C, Decision (X Y)}.
Lemma not_elem_of_intersection x X Y : x X Y x X x Y.
Proof.
rewrite elem_of_intersection.
destruct (decide (x X)); tauto.
Qed.
Lemma not_elem_of_difference x X Y : x X Y x X x Y.
Proof.
rewrite elem_of_difference.
destruct (decide (x Y)); tauto.
Qed.
Lemma union_difference X Y : X Y Y X Y X.
Proof.
split; intros x; rewrite !elem_of_union, elem_of_difference.
* destruct (decide (x X)); intuition.
* intuition.
Qed.
Lemma non_empty_difference X Y : X Y Y X .
Proof.
intros [HXY1 HXY2] Hdiff. destruct HXY2. intros x.
destruct (decide (x X)); esolve_elem_of.
Qed.
End collection.
(** * Sets without duplicates up to an equivalence *) (** * Sets without duplicates up to an equivalence *)
Section no_dup. Section no_dup.
Context `{SimpleCollection A B} (R : relation A) `{!Equivalence R}. Context `{SimpleCollection A B} (R : relation A) `{!Equivalence R}.
...@@ -202,7 +246,7 @@ Section no_dup. ...@@ -202,7 +246,7 @@ Section no_dup.
Definition no_dup (X : B) := x y, x X y X R x y x = y. Definition no_dup (X : B) := x y, x X y X R x y x = y.
Global Instance: Proper (() ==> iff) (elem_of_upto x). Global Instance: Proper (() ==> iff) (elem_of_upto x).
Proof. firstorder. Qed. Proof. intros ??? E. unfold elem_of_upto. by setoid_rewrite E. Qed.
Global Instance: Proper (R ==> () ==> iff) elem_of_upto. Global Instance: Proper (R ==> () ==> iff) elem_of_upto.
Proof. Proof.
intros ?? E1 ?? E2. split; intros [z [??]]; exists z. intros ?? E1 ?? E2. split; intros [z [??]]; exists z.
...@@ -390,10 +434,13 @@ Section collection_monad. ...@@ -390,10 +434,13 @@ Section collection_monad.
l mapM f k l mapM f k
Forall (λ x, y, y f x P y) k Forall (λ x, y, y f x P y) k
Forall P l. Forall P l.
Proof. rewrite elem_of_mapM. apply Forall2_Forall_1. Qed. Proof. rewrite elem_of_mapM. apply Forall2_Forall_l. Qed.
Lemma elem_of_mapM_Forall2_l {A B C} (f : A M B) (P : B C Prop) l1 l2 k :
Lemma mapM_non_empty {A B} (f : A M B) l : l1 mapM f k
Forall (λ x, y, y f x) l Forall2 (λ x y, z, z f x P z y) k l2
k, k mapM f l. Forall2 P l1 l2.
Proof. induction 1; esolve_elem_of. Qed. Proof.
rewrite elem_of_mapM. intros Hl1. revert l2.
induction Hl1; inversion_clear 1; constructor; auto.
Qed.
End collection_monad. End collection_monad.
...@@ -5,6 +5,8 @@ with a decidable equality. Such propositions are collected by the [Decision] ...@@ -5,6 +5,8 @@ with a decidable equality. Such propositions are collected by the [Decision]
type class. *) type class. *)
Require Export base tactics. Require Export base tactics.
Hint Extern 200 (Decision _) => progress (lazy beta) : typeclass_instances.
Lemma dec_stable `{Decision P} : ¬¬P P. Lemma dec_stable `{Decision P} : ¬¬P P.
Proof. firstorder. Qed. Proof. firstorder. Qed.
...@@ -82,6 +84,8 @@ combination with the [refine] tactic. *) ...@@ -82,6 +84,8 @@ combination with the [refine] tactic. *)
Notation cast_if S := (if S then left _ else right _). Notation cast_if S := (if S then left _ else right _).
Notation cast_if_and S1 S2 := (if S1 then cast_if S2 else right _). Notation cast_if_and S1 S2 := (if S1 then cast_if S2 else right _).
Notation cast_if_and3 S1 S2 S3 := (if S1 then cast_if_and S2 S3 else right _). Notation cast_if_and3 S1 S2 S3 := (if S1 then cast_if_and S2 S3 else right _).
Notation cast_if_and4 S1 S2 S3 S4 :=
(if S1 then cast_if_and3 S2 S3 S4 else right _).
Notation cast_if_or S1 S2 := (if S1 then left _ else cast_if S2). Notation cast_if_or S1 S2 := (if S1 then left _ else cast_if S2).
Notation cast_if_not S := (if S then right _ else left _). Notation cast_if_not S := (if S then right _ else left _).
...@@ -104,14 +108,24 @@ Section prop_dec. ...@@ -104,14 +108,24 @@ Section prop_dec.
End prop_dec. End prop_dec.
(** Instances of [Decision] for common data types. *) (** Instances of [Decision] for common data types. *)
Instance bool_eq_dec (x y : bool) : Decision (x = y).
Proof. solve_decision. Defined.
Instance unit_eq_dec (x y : unit) : Decision (x = y). Instance unit_eq_dec (x y : unit) : Decision (x = y).
Proof. refine (left _); by destruct x, y. Defined. Proof. refine (left _); by destruct x, y. Defined.
Instance prod_eq_dec `(A_dec : x y : A, Decision (x = y)) Instance prod_eq_dec `(A_dec : x y : A, Decision (x = y))
`(B_dec : x y : B, Decision (x = y)) (x y : A * B) : Decision (x = y). `(B_dec : x y : B, Decision (x = y)) (x y : A * B) : Decision (x = y).
Proof. Proof.
refine (cast_if_and (A_dec (fst x) (fst y)) (B_dec (snd x) (snd y))); refine (cast_if_and (A_dec (fst x) (fst y)) (B_dec (snd x) (snd y)));
abstract (destruct x, y; simpl in *; congruence). abstract (destruct x, y; simpl in *; congruence).
Defined. Defined.
Instance sum_eq_dec `(A_dec : x y : A, Decision (x = y)) Instance sum_eq_dec `(A_dec : x y : A, Decision (x = y))
`(B_dec : x y : B, Decision (x = y)) (x y : A + B) : Decision (x = y). `(B_dec : x y : B, Decision (x = y)) (x y : A + B) : Decision (x = y).
Proof. solve_decision. Defined. Proof. solve_decision. Defined.
Instance curry_dec `(P_dec : (x : A) (y : B), Decision (P x y)) p :
Decision (curry P p) :=
match p as p return Decision (curry P p) with
| (x,y) => P_dec x y
end.
Instance uncurry_dec `(P_dec : (p : A * B), Decision (P p)) x y :
Decision (uncurry P x y) := P_dec (x,y).
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
(** This file collects definitions and theorems on finite collections. Most (** This file collects definitions and theorems on finite collections. Most
importantly, it implements a fold and size function and some useful induction importantly, it implements a fold and size function and some useful induction
principles on finite collections . *) principles on finite collections . *)
Require Import Permutation. Require Import Permutation ars.
Require Export collections numbers listset. Require Export collections numbers listset.
Instance collection_size `{Elements A C} : Size C := length elements. Instance collection_size `{Elements A C} : Size C := length elements.
...@@ -37,6 +37,8 @@ Proof. ...@@ -37,6 +37,8 @@ Proof.
Qed. Qed.
Lemma size_empty_iff (X : C) : size X = 0 X . Lemma size_empty_iff (X : C) : size X = 0 X .
Proof. split. apply size_empty_inv. intros E. by rewrite E, size_empty. Qed. Proof. split. apply size_empty_inv. intros E. by rewrite E, size_empty. Qed.
Lemma size_non_empty_iff (X : C) : size X 0 X .
Proof. by rewrite size_empty_iff. Qed.
Lemma size_singleton (x : A) : size {[ x ]} = 1. Lemma size_singleton (x : A) : size {[ x ]} = 1.
Proof. Proof.
...@@ -123,54 +125,38 @@ Qed. ...@@ -123,54 +125,38 @@ Qed.
Lemma size_union_alt X Y : size (X Y) = size X + size (Y X). Lemma size_union_alt X Y : size (X Y) = size X + size (Y X).
Proof. Proof.
rewrite <-size_union. by rewrite union_difference. solve_elem_of. rewrite <-size_union by solve_elem_of.
Qed. setoid_replace (Y X) with ((Y X) X) by esolve_elem_of.
Lemma size_add X x : x X size ({[ x ]} X) = S (size X). rewrite <-union_difference, (commutative ()); solve_elem_of.
Proof.
intros. rewrite size_union. by rewrite size_singleton. solve_elem_of.
Qed.
Lemma size_difference X Y : X Y size X + size (Y X) = size Y.
Proof. intros. by rewrite <-size_union_alt, subseteq_union_1. Qed.
Lemma size_remove X x : x X S (size (X {[ x ]})) = size X.
Proof.
intros. rewrite <-(size_difference {[ x ]} X).
* rewrite size_singleton. auto with arith.
* solve_elem_of.
Qed. Qed.
Lemma subseteq_size X Y : X Y size X size Y. Lemma subseteq_size X Y : X Y size X size Y.
Proof. Proof.
intros. rewrite <-(subseteq_union_1 X Y) by done. intros. rewrite (union_difference X Y), size_union_alt by done. lia.
rewrite <-(union_difference X Y), size_union by solve_elem_of.
auto with arith.
Qed. Qed.
Lemma subset_size X Y : X Y size X < size Y.
Lemma collection_wf_ind (P : C Prop) :
( X, ( Y, size Y < size X P Y) P X)
X, P X.
Proof. Proof.
intros Hind. cut ( n X, size X < n P X). intros. rewrite (union_difference X Y) by solve_elem_of.
{ intros help X. apply help with (S (size X)). auto with arith. } rewrite size_union_alt, difference_twice.
induction n; intros. cut (size (Y X) 0); [lia |].
* by destruct (Lt.lt_n_0 (size X)). by apply size_non_empty_iff, non_empty_difference.
* apply Hind. intros. apply IHn. eauto with arith.
Qed. Qed.
Lemma collection_wf : wf (@subset C _).
Proof. apply well_founded_lt_compat with size, subset_size. Qed.
Lemma collection_ind (P : C Prop) : Lemma collection_ind (P : C Prop) :
Proper (() ==> iff) P Proper (() ==> iff) P
P P
( x X, x X P X P ({[ x ]} X)) ( x X, x X P X P ({[ x ]} X))
X, P X. X, P X.
Proof. Proof.
intros ? Hemp Hadd. apply collection_wf_ind. intros ? Hemp Hadd. apply well_founded_induction with ().
intros X IH. destruct (Compare_dec.zerop (size X)). { apply collection_wf. }
* by rewrite size_empty_inv. intros X IH. destruct (elem_of_or_empty X) as [[x ?]|HX].
* destruct (size_pos_choose X); auto. * rewrite (union_difference {[ x ]} X) by solve_elem_of.
rewrite <-(subseteq_union_1 {[ x ]} X) by solve_elem_of. apply Hadd. solve_elem_of. apply IH. esolve_elem_of.
rewrite <-union_difference. * by rewrite HX.
apply Hadd; [solve_elem_of |]. apply IH.
rewrite <-(size_remove X x); auto with arith.
Qed. Qed.
Lemma collection_fold_ind {B} (P : B C Prop) (f : A B B) (b : B) : Lemma collection_fold_ind {B} (P : B C Prop) (f : A B B) (b : B) :
...@@ -182,16 +168,12 @@ Proof. ...@@ -182,16 +168,12 @@ Proof.
intros ? Hemp Hadd. intros ? Hemp Hadd.
cut ( l, NoDup l X, ( x, x X x l) P (foldr f b l) X). cut ( l, NoDup l X, ( x, x X x l) P (foldr f b l) X).
{ intros help ?. apply help. apply elements_nodup. apply elements_spec. } { intros help ?. apply help. apply elements_nodup. apply elements_spec. }
induction 1 as [|x l ?? IHl]. induction 1 as [|x l ?? IH]; simpl.
* intros X HX. setoid_rewrite elem_of_nil in HX. * intros X HX. setoid_rewrite elem_of_nil in HX.
rewrite equiv_empty; firstorder. rewrite equiv_empty. done. esolve_elem_of.
* intros X HX. setoid_rewrite elem_of_cons in HX. * intros X HX. setoid_rewrite elem_of_cons in HX.
rewrite <-(subseteq_union_1 {[ x ]} X) by esolve_elem_of. rewrite (union_difference {[ x ]} X) by esolve_elem_of.
rewrite <-union_difference. apply Hadd. solve_elem_of. apply IH. esolve_elem_of.
apply Hadd. solve_elem_of. apply IHl.
intros y. split.
+ intros. destruct (proj1 (HX y)); solve_elem_of.
+ esolve_elem_of.
Qed. Qed.
Lemma collection_fold_proper {B} (R : relation B) Lemma collection_fold_proper {B} (R : relation B)
......
This diff is collapsed.
This diff is collapsed.
...@@ -20,29 +20,44 @@ Instance listset_empty: Empty (listset A) := ...@@ -20,29 +20,44 @@ Instance listset_empty: Empty (listset A) :=
Instance listset_singleton: Singleton A (listset A) := λ x, Instance listset_singleton: Singleton A (listset A) := λ x,
Listset [x]. Listset [x].
Instance listset_union: Union (listset A) := λ l k, Instance listset_union: Union (listset A) := λ l k,
Listset (listset_car l ++ listset_car k). match l, k with
| Listset l', Listset k' => Listset (l' ++ k')
end.
Global Instance: SimpleCollection A (listset A). Global Instance: SimpleCollection A (listset A).
Proof. Proof.
split. split.
* by apply not_elem_of_nil. * by apply not_elem_of_nil.
* by apply elem_of_list_singleton. * by apply elem_of_list_singleton.
* intros. apply elem_of_app. * intros [?] [?]. apply elem_of_app.
Qed. Qed.
Context `{ x y : A, Decision (x = y)}. Context `{ x y : A, Decision (x = y)}.
Instance listset_intersection: Intersection (listset A) := λ l k, Instance listset_intersection: Intersection (listset A) := λ l k,
Listset (list_intersection (listset_car l) (listset_car k)). match l, k with
| Listset l', Listset k' => Listset (list_intersection l' k')
end.
Instance listset_difference: Difference (listset A) := λ l k, Instance listset_difference: Difference (listset A) := λ l k,
Listset (list_difference (listset_car l) (listset_car k)). match l, k with
| Listset l', Listset k' => Listset (list_difference l' k')
end.
Instance listset_intersection_with: IntersectionWith A (listset A) := λ f l k,
match l, k with
| Listset l', Listset k' => Listset (list_intersection_with f l' k')
end.
Instance listset_filter: Filter A (listset A) := λ P _ l,
match l with
| Listset l' => Listset (filter P l')
end.
Global Instance: Collection A (listset A). Global Instance: Collection A (listset A).
Proof. Proof.
split. split.
* apply _. * apply _.
* intros. apply elem_of_list_intersection. * intros [?] [?]. apply elem_of_list_intersection.
* intros. apply elem_of_list_difference. * intros [?] [?]. apply elem_of_list_difference.
* intros ? [?] [?]. apply elem_of_list_intersection_with.
Qed. Qed.
Instance listset_elems: Elements A (listset A) := Instance listset_elems: Elements A (listset A) :=
...@@ -52,6 +67,7 @@ Global Instance: FinCollection A (listset A). ...@@ -52,6 +67,7 @@ Global Instance: FinCollection A (listset A).
Proof. Proof.
split. split.
* apply _. * apply _.
* intros [?] ??. apply elem_of_list_filter.
* symmetry. apply elem_of_remove_dups. * symmetry. apply elem_of_remove_dups.
* intros. apply remove_dups_nodup. * intros. apply remove_dups_nodup.
Qed. Qed.
...@@ -69,27 +85,35 @@ Hint Extern 1 (Union (listset _)) => ...@@ -69,27 +85,35 @@ Hint Extern 1 (Union (listset _)) =>
eapply @listset_union : typeclass_instances. eapply @listset_union : typeclass_instances.
Hint Extern 1 (Intersection (listset _)) => Hint Extern 1 (Intersection (listset _)) =>
eapply @listset_intersection : typeclass_instances. eapply @listset_intersection : typeclass_instances.
Hint Extern 1 (IntersectionWith _ (listset _)) =>
eapply @listset_intersection_with : typeclass_instances.
Hint Extern 1 (Difference (listset _)) => Hint Extern 1 (Difference (listset _)) =>
eapply @listset_difference : typeclass_instances. eapply @listset_difference : typeclass_instances.
Hint Extern 1 (Elements _ (listset _)) => Hint Extern 1 (Elements _ (listset _)) =>
eapply @listset_elems : typeclass_instances. eapply @listset_elems : typeclass_instances.
Hint Extern 1 (Filter _ (listset _)) =>
eapply @listset_filter : typeclass_instances.
Instance listset_ret: MRet listset := λ A x, Instance listset_ret: MRet listset := λ A x,
{[ x ]}. </