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.
Section rtc.
Context `{R : relation A}.
Global Instance: Reflexive (rtc R).
Proof rtc_refl R.
Global Instance rtc_trans: Transitive (rtc R).
Proof. red; induction 1; eauto with ars. Qed.
Instance rtc_preorder: PreOrder (rtc R).
Proof.
split.
* red. apply rtc_refl.
* red. induction 1; eauto with ars.
Qed.
Lemma rtc_once x y : R x y rtc R x y.
Proof. eauto with ars. Qed.
Global Instance: subrelation R (rtc R).
Instance rtc_once_subrel: subrelation R (rtc R).
Proof. exact @rtc_once. Qed.
Lemma rtc_r x y z : rtc R x y R y z rtc R x z.
Proof. intros. etransitivity; eauto with ars. Qed.
......@@ -142,7 +144,7 @@ Section rtc.
Proof. intros. etransitivity; eauto with ars. Qed.
Lemma tc_rtc x y : tc R x y rtc R x y.
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.
Lemma looping_red x : looping R x red R x.
......@@ -163,6 +165,14 @@ Section rtc.
Qed.
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
rtc_once rtc_r
tc_r
......@@ -186,3 +196,35 @@ Section subrel.
Global Instance tc_subrel: subrelation (tc R1) (tc R2).
Proof. induction 1; [left|eright]; eauto; by apply Hsub. Qed.
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.
Global Instance elem_of_proper: Proper ((=) ==> () ==> iff) () | 5.
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.
Proof.
split.
......@@ -60,7 +60,7 @@ Section simple_collection.
Lemma not_elem_of_union x X Y : x X Y x X x Y.
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.
Proof.
......@@ -69,37 +69,6 @@ Section simple_collection.
Defined.
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
match goal with
| H : _ _ |- _ => apply empty_union in H; destruct H
......@@ -116,6 +85,7 @@ Ltac unfold_elem_of :=
repeat_on_hyps (fun H =>
repeat match type of H with
| 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_empty in H
| context [ _ {[ _ ]} ] => setoid_rewrite elem_of_singleton in H
......@@ -129,6 +99,7 @@ Ltac unfold_elem_of :=
end);
repeat match goal with
| |- context [ _ _ ] => setoid_rewrite elem_of_subseteq
| |- context [ _ _ ] => setoid_rewrite subset_spec
| |- context [ _ _ ] => setoid_rewrite elem_of_equiv_alt
| |- context [ _ ] => setoid_rewrite elem_of_empty
| |- context [ _ {[ _ ]} ] => setoid_rewrite elem_of_singleton
......@@ -194,6 +165,79 @@ Tactic Notation "decompose_elem_of" hyp(H) :=
Tactic Notation "decompose_elem_of" :=
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 *)
Section no_dup.
Context `{SimpleCollection A B} (R : relation A) `{!Equivalence R}.
......@@ -202,7 +246,7 @@ Section no_dup.
Definition no_dup (X : B) := x y, x X y X R x y x = y.
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.
Proof.
intros ?? E1 ?? E2. split; intros [z [??]]; exists z.
......@@ -390,10 +434,13 @@ Section collection_monad.
l mapM f k
Forall (λ x, y, y f x P y) k
Forall P l.
Proof. rewrite elem_of_mapM. apply Forall2_Forall_1. Qed.
Lemma mapM_non_empty {A B} (f : A M B) l :
Forall (λ x, y, y f x) l
k, k mapM f l.
Proof. induction 1; esolve_elem_of. 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 :
l1 mapM f k
Forall2 (λ x y, z, z f x P z y) k l2
Forall2 P l1 l2.
Proof.
rewrite elem_of_mapM. intros Hl1. revert l2.
induction Hl1; inversion_clear 1; constructor; auto.
Qed.
End collection_monad.
......@@ -5,6 +5,8 @@ with a decidable equality. Such propositions are collected by the [Decision]
type class. *)
Require Export base tactics.
Hint Extern 200 (Decision _) => progress (lazy beta) : typeclass_instances.
Lemma dec_stable `{Decision P} : ¬¬P P.
Proof. firstorder. Qed.
......@@ -82,6 +84,8 @@ combination with the [refine] tactic. *)
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_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_not S := (if S then right _ else left _).
......@@ -104,14 +108,24 @@ Section prop_dec.
End prop_dec.
(** 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).
Proof. refine (left _); by destruct x, y. Defined.
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.
refine (cast_if_and (A_dec (fst x) (fst y)) (B_dec (snd x) (snd y)));
abstract (destruct x, y; simpl in *; congruence).
Defined.
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.
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 @@
(** This file collects definitions and theorems on finite collections. Most
importantly, it implements a fold and size function and some useful induction
principles on finite collections . *)
Require Import Permutation.
Require Import Permutation ars.
Require Export collections numbers listset.
Instance collection_size `{Elements A C} : Size C := length elements.
......@@ -37,6 +37,8 @@ Proof.
Qed.
Lemma size_empty_iff (X : C) : size X = 0 X .
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.
Proof.
......@@ -123,54 +125,38 @@ Qed.
Lemma size_union_alt X Y : size (X Y) = size X + size (Y X).
Proof.
rewrite <-size_union. by rewrite union_difference. solve_elem_of.
Qed.
Lemma size_add X x : x X size ({[ x ]} X) = S (size X).
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.
rewrite <-size_union by solve_elem_of.
setoid_replace (Y X) with ((Y X) X) by esolve_elem_of.
rewrite <-union_difference, (commutative ()); solve_elem_of.
Qed.
Lemma subseteq_size X Y : X Y size X size Y.
Proof.
intros. rewrite <-(subseteq_union_1 X Y) by done.
rewrite <-(union_difference X Y), size_union by solve_elem_of.
auto with arith.
intros. rewrite (union_difference X Y), size_union_alt by done. lia.
Qed.
Lemma collection_wf_ind (P : C Prop) :
( X, ( Y, size Y < size X P Y) P X)
X, P X.
Lemma subset_size X Y : X Y size X < size Y.
Proof.
intros Hind. cut ( n X, size X < n P X).
{ intros help X. apply help with (S (size X)). auto with arith. }
induction n; intros.
* by destruct (Lt.lt_n_0 (size X)).
* apply Hind. intros. apply IHn. eauto with arith.
intros. rewrite (union_difference X Y) by solve_elem_of.
rewrite size_union_alt, difference_twice.
cut (size (Y X) 0); [lia |].
by apply size_non_empty_iff, non_empty_difference.
Qed.
Lemma collection_wf : wf (@subset C _).
Proof. apply well_founded_lt_compat with size, subset_size. Qed.
Lemma collection_ind (P : C Prop) :
Proper (() ==> iff) P
P
( x X, x X P X P ({[ x ]} X))
X, P X.
Proof.
intros ? Hemp Hadd. apply collection_wf_ind.
intros X IH. destruct (Compare_dec.zerop (size X)).
* by rewrite size_empty_inv.
* destruct (size_pos_choose X); auto.
rewrite <-(subseteq_union_1 {[ x ]} X) by solve_elem_of.
rewrite <-union_difference.
apply Hadd; [solve_elem_of |]. apply IH.
rewrite <-(size_remove X x); auto with arith.
intros ? Hemp Hadd. apply well_founded_induction with ().
{ apply collection_wf. }
intros X IH. destruct (elem_of_or_empty X) as [[x ?]|HX].
* rewrite (union_difference {[ x ]} X) by solve_elem_of.
apply Hadd. solve_elem_of. apply IH. esolve_elem_of.
* by rewrite HX.
Qed.
Lemma collection_fold_ind {B} (P : B C Prop) (f : A B B) (b : B) :
......@@ -182,16 +168,12 @@ Proof.
intros ? Hemp Hadd.
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. }
induction 1 as [|x l ?? IHl].
induction 1 as [|x l ?? IH]; simpl.
* 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.
rewrite <-(subseteq_union_1 {[ x ]} X) by esolve_elem_of.
rewrite <-union_difference.
apply Hadd. solve_elem_of. apply IHl.
intros y. split.
+ intros. destruct (proj1 (HX y)); solve_elem_of.
+ esolve_elem_of.
rewrite (union_difference {[ x ]} X) by esolve_elem_of.
apply Hadd. solve_elem_of. apply IH. esolve_elem_of.
Qed.
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) :=
Instance listset_singleton: Singleton A (listset A) := λ x,
Listset [x].
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).
Proof.
split.
* by apply not_elem_of_nil.
* by apply elem_of_list_singleton.
* intros. apply elem_of_app.
* intros [?] [?]. apply elem_of_app.
Qed.
Context `{ x y : A, Decision (x = y)}.
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,
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).
Proof.
split.
* apply _.
* intros. apply elem_of_list_intersection.
* intros. apply elem_of_list_difference.
* intros [?] [?]. apply elem_of_list_intersection.
* intros [?] [?]. apply elem_of_list_difference.
* intros ? [?] [?]. apply elem_of_list_intersection_with.
Qed.
Instance listset_elems: Elements A (listset A) :=
......@@ -52,6 +67,7 @@ Global Instance: FinCollection A (listset A).
Proof.
split.
* apply _.
* intros [?] ??. apply elem_of_list_filter.
* symmetry. apply elem_of_remove_dups.
* intros. apply remove_dups_nodup.
Qed.
......@@ -69,27 +85,35 @@ Hint Extern 1 (Union (listset _)) =>
eapply @listset_union : typeclass_instances.
Hint Extern 1 (Intersection (listset _)) =>
eapply @listset_intersection : typeclass_instances.
Hint Extern 1 (IntersectionWith _ (listset _)) =>
eapply @listset_intersection_with : typeclass_instances.
Hint Extern 1 (Difference (listset _)) =>
eapply @listset_difference : typeclass_instances.
Hint Extern 1 (Elements _ (listset _)) =>
eapply @listset_elems : typeclass_instances.
Hint Extern 1 (Filter _ (listset _)) =>
eapply @listset_filter : typeclass_instances.
Instance listset_ret: MRet listset := λ A x,
{[ x ]}.
Instance listset_fmap: FMap listset := λ A B f l,
Listset (f <$> listset_car l).
match l with
| Listset l' => Listset (f <$> l')
end.
Instance listset_bind: MBind listset := λ A B f l,
Listset (mbind (listset_car f) (listset_car l)).
match l with
| Listset l' => Listset (mbind (listset_car f) l')
end.
Instance listset_join: MJoin listset := λ A, mbind id.
Instance: CollectionMonad listset.
Proof.
split.
* intros. apply _.
* intros. apply elem_of_list_bind.
* intros ??? [?] ?. apply elem_of_list_bind.
* intros. apply elem_of_list_ret.
* intros. apply elem_of_list_fmap.
* intros ?? [l].
* intros ??? [?]. apply elem_of_list_fmap.
* intros ? [?] ?.
unfold mjoin, listset_join, elem_of, listset_elem_of.
simpl. by rewrite elem_of_list_bind.
Qed.
(* Copyright (c) 2012, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This file implements finite as unordered lists without duplicates.
Although this implementation is slow, it is very useful as decidable equality
is the only constraint on the carrier set. *)
Require Export base decidable collections list.
Record listset_nodup A := ListsetNoDup {
listset_nodup_car : list A;
listset_nodup_prf : NoDup listset_nodup_car
}.
Arguments ListsetNoDup {_} _ _.
Arguments listset_nodup_car {_} _.
Arguments listset_nodup_prf {_} _.
Section list_collection.
Context {A : Type} `{ x y : A, Decision (x = y)}.
Notation C := (listset_nodup A).
Notation LS := ListsetNoDup.
Instance listset_nodup_elem_of: ElemOf A C := λ x l,
x listset_nodup_car l.
Instance listset_nodup_empty: Empty C :=
LS [] (@NoDup_nil_2 _).
Instance listset_nodup_singleton: Singleton A C := λ x,
LS [x] (NoDup_singleton x).
Instance listset_nodup_difference: Difference C := λ l k,
LS _ (list_difference_nodup _ (listset_nodup_car k) (listset_nodup_prf l)).
Definition listset_nodup_union_raw (l k : list A) : list A :=
list_difference l k ++ k.
Lemma elem_of_listset_nodup_union_raw l k x :
x listset_nodup_union_raw l k x l x k.
Proof.
unfold listset_nodup_union_raw.
rewrite elem_of_app, elem_of_list_difference.
intuition. case (decide (x k)); intuition.
Qed.
Lemma listset_nodup_union_raw_nodup l k :
NoDup l NoDup k NoDup (listset_nodup_union_raw l k).
Proof.
intros. apply NoDup_app. repeat split.
* by apply list_difference_nodup.
* intro. rewrite elem_of_list_difference. intuition.
* done.
Qed.
Instance listset_nodup_union: Union C := λ l k,
LS _ (listset_nodup_union_raw_nodup _ _
(listset_nodup_prf l) (listset_nodup_prf k)).