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].
......@@ -12,9 +12,11 @@ Require Export Morphisms RelationClasses List Bool Utf8 Program Setoid NArith.
(** The following coercion allows us to use Booleans as propositions. *)
Coercion Is_true : bool >-> Sortclass.
(** Ensure that [simpl] unfolds [id] and [compose] when fully applied. *)
(** Ensure that [simpl] unfolds [id], [compose], and [flip] when fully
applied. *)
Arguments id _ _/.
Arguments compose _ _ _ _ _ _ /.
Arguments flip _ _ _ _ _ _/.
(** Change [True] and [False] into notations in order to enable overloading.
We will use this in the file [assertions] to give [True] and [False] a
......@@ -23,6 +25,9 @@ semantics. *)
Notation "'True'" := True : type_scope.
Notation "'False'" := False : type_scope.
Notation curry := prod_curry.
Notation uncurry := prod_uncurry.
(** Throughout this development we use [C_scope] for all general purpose
notations that do not belong to a more specific scope. *)
Delimit Scope C_scope with C.
......@@ -159,6 +164,17 @@ Notation "( ⊈ X )" := (λ Y, Y ⊈ X) (only parsing) : C_scope.
Hint Extern 0 (_ _) => reflexivity.
Class Subset A := subset: A A Prop.
Instance: Params (@subset) 2.
Infix "⊂" := subset (at level 70) : C_scope.
Notation "(⊂)" := subset (only parsing) : C_scope.
Notation "( X ⊂ )" := (subset X) (only parsing) : C_scope.
Notation "( ⊂ X )" := (λ Y, subset Y X) (only parsing) : C_scope.
Notation "X ⊄ Y" := (¬X Y) (at level 70) : C_scope.
Notation "(⊄)" := (λ X Y, X Y) (only parsing) : C_scope.
Notation "( X ⊄ )" := (λ Y, X Y) (only parsing) : C_scope.
Notation "( ⊄ X )" := (λ Y, Y X) (only parsing) : C_scope.
Class ElemOf A B := elem_of: A B Prop.
Instance: Params (@elem_of) 3.
Infix "∈" := elem_of (at level 70) : C_scope.
......@@ -192,6 +208,10 @@ Proof. inversion_clear 1; auto. Qed.
Instance generic_disjoint `{ElemOf A B} : Disjoint B | 100 :=
λ X Y, x, x X x Y.
Class Filter A B :=
filter: (P : A Prop) `{ x, Decision (P x)}, B B.
(* Arguments filter {_ _ _} _ {_} !_ / : simpl nomatch. *)
(** ** Monadic operations *)
(** We define operational type classes for the monadic operations bind, join
and fmap. These type classes are defined in a non-standard way by taking the
......@@ -230,9 +250,13 @@ Instance: Params (@fmap) 6.
Arguments fmap {_ _ _} _ {_} !_ / : simpl nomatch.
Notation "m ≫= f" := (mbind f m) (at level 60, right associativity) : C_scope.
Notation "( m ≫=)" := (λ f, mbind f m) (only parsing) : C_scope.
Notation "(≫= f )" := (mbind f) (only parsing) : C_scope.
Notation "(≫=)" := (λ m f, mbind f m) (only parsing) : C_scope.
Notation "x ← y ; z" := (y = (λ x : _, z))
(at level 65, only parsing, next at level 35, right associativity) : C_scope.
Infix "<$>" := fmap (at level 65, right associativity, only parsing) : C_scope.
Infix "<$>" := fmap (at level 65, right associativity) : C_scope.
Class MGuard (M : Type Type) :=
mguard: P {dec : Decision P} {A}, M A M A.
......@@ -243,7 +267,7 @@ Notation "'guard' P ; o" := (mguard P o)
(** In this section we define operational type classes for the operations
on maps. In the file [fin_maps] we will axiomatize finite maps.
The function lookup [m !! k] should yield the element at key [k] in [m]. *)
Class Lookup (K M A : Type) :=
Class Lookup (K A M : Type) :=
lookup: K M option A.
Instance: Params (@lookup) 4.
......@@ -255,7 +279,7 @@ Arguments lookup _ _ _ _ !_ !_ / : simpl nomatch.
(** The function insert [<[k:=a]>m] should update the element at key [k] with
value [a] in [m]. *)
Class Insert (K M A : Type) :=
Class Insert (K A M : Type) :=
insert: K A M M.
Instance: Params (@insert) 4.
Notation "<[ k := a ]>" := (insert k a)
......@@ -272,9 +296,9 @@ Arguments delete _ _ _ !_ !_ / : simpl nomatch.
(** The function [alter f k m] should update the value at key [k] using the
function [f], which is called with the original value. *)
Class AlterD (K M A : Type) (f : A A) :=
Class AlterD (K A M : Type) (f : A A) :=
alter: K M M.
Notation Alter K M A := ( (f : A A), AlterD K M A f)%type.
Notation Alter K A M := ( (f : A A), AlterD K A M f)%type.
Instance: Params (@alter) 5.
Arguments alter {_ _ _} _ {_} !_ !_ / : simpl nomatch.
......@@ -282,7 +306,7 @@ Arguments alter {_ _ _} _ {_} !_ !_ / : simpl nomatch.
function [f], which is called with the original value at key [k] or [None]
if [k] is not a member of [m]. The value at [k] should be deleted if [f]
yields [None]. *)
Class PartialAlter (K M A : Type) :=
Class PartialAlter (K A M : Type) :=
partial_alter: (option A option A) K M M.
Instance: Params (@partial_alter) 4.
Arguments partial_alter _ _ _ _ _ !_ !_ / : simpl nomatch.
......@@ -297,39 +321,43 @@ Arguments dom _ _ _ _ _ _ _ !_ / : simpl nomatch.
(** The function [merge f m1 m2] should merge the maps [m1] and [m2] by
constructing a new map whose value at key [k] is [f (m1 !! k) (m2 !! k)]
provided that [k] is a member of either [m1] or [m2].*)
Class Merge (M : Type Type) :=
merge: {A}, (option A option A option A) M A M A M A.
Class Merge (A M : Type) :=
merge: (option A option A option A) M M M.
Instance: Params (@merge) 3.
Arguments merge _ _ _ _ !_ !_ / : simpl nomatch.
(** We lift the insert and delete operation to lists of elements. *)
Definition insert_list `{Insert K M A} (l : list (K * A)) (m : M) : M :=
Definition insert_list `{Insert K A M} (l : list (K * A)) (m : M) : M :=
fold_right (λ p, <[ fst p := snd p ]>) m l.
Instance: Params (@insert_list) 4.
Definition delete_list `{Delete K M} (l : list K) (m : M) : M :=
fold_right delete m l.
Instance: Params (@delete_list) 3.
Definition insert_consecutive `{Insert nat M A}
Definition insert_consecutive `{Insert nat A M}
(i : nat) (l : list A) (m : M) : M :=
fold_right (λ x f i, <[i:=x]>(f (S i))) (λ _, m) l i.
Instance: Params (@insert_consecutive) 3.
(** The function [union_with f m1 m2] should yield the union of [m1] and [m2]
using the function [f] to combine values of members that are in both [m1] and
[m2]. *)
Class UnionWith (M : Type Type) :=
union_with: {A}, (A A A) M A M A M A.
(** The function [union_with f m1 m2] is supposed to yield the union of [m1]
and [m2] using the function [f] to combine values of members that are in
both [m1] and [m2]. *)
Class UnionWith (A M : Type) :=
union_with: (A A option A) M M M.
Instance: Params (@union_with) 3.
(** Similarly for the intersection and difference. *)
Class IntersectionWith (M : Type Type) :=
intersection_with: {A}, (A A A) M A M A M A.
(** Similarly for intersection and difference. *)
Class IntersectionWith (A M : Type) :=
intersection_with: (A A option A) M M M.
Instance: Params (@intersection_with) 3.
Class DifferenceWith (M : Type Type) :=
difference_with: {A}, (A A option A) M A M A M A.
Class DifferenceWith (A M : Type) :=
difference_with: (A A option A) M M M.
Instance: Params (@difference_with) 3.
Definition intersection_with_list `{IntersectionWith A M}
(f : A A option A) : M list M M := fold_right (intersection_with f).
Arguments intersection_with_list _ _ _ _ _ !_ /.
(** ** Common properties *)
(** These operational type classes allow us to refer to common mathematical
properties in a generic way. For example, for injectivity of [(k ++)] it
......@@ -350,6 +378,8 @@ Class LeftAbsorb {A} R (i : A) (f : A → A → A) :=
left_absorb: x, R (f i x) i.
Class RightAbsorb {A} R (i : A) (f : A A A) :=
right_absorb: x, R (f x i) i.
Class AntiSymmetric {A} (R : A A Prop) :=
anti_symmetric: x y, R x y R y x x = y.
Arguments injective {_ _ _ _} _ {_} _ _ _.
Arguments idempotent {_ _} _ {_} _.
......@@ -359,6 +389,7 @@ Arguments right_id {_ _} _ _ {_} _.
Arguments associative {_ _} _ {_} _ _ _.
Arguments left_absorb {_ _} _ _ {_} _.
Arguments right_absorb {_ _} _ _ {_} _.
Arguments anti_symmetric {_} _ {_} _ _ _ _.
(** The following lemmas are more specific versions of the projections of the
above type classes. These lemmas allow us to enforce Coq not to use the setoid
......@@ -391,6 +422,10 @@ Class BoundedPreOrder A `{Empty A} `{SubsetEq A} := {
bounded_preorder :>> PreOrder ();
subseteq_empty x : x
}.
Class PartialOrder A `{SubsetEq A} := {
po_preorder :>> PreOrder ();
po_antisym :> AntiSymmetric ()
}.
(** We do not include equality in the following interfaces so as to avoid the
need for proofs that the relations and operations respect setoid equality.
......@@ -423,11 +458,13 @@ Class SimpleCollection A C `{ElemOf A C}
elem_of_singleton (x y : A) : x {[ y ]} x = y;
elem_of_union X Y (x : A) : x X Y x X x Y
}.
Class Collection A C `{ElemOf A C} `{Empty C} `{Singleton A C} `{Union C}
`{Intersection C} `{Difference C} := {
Class Collection A C `{ElemOf A C} `{Empty C} `{Singleton A C}
`{Union C} `{Intersection C} `{Difference C} `{IntersectionWith A C} := {
collection_simple :>> SimpleCollection A C;
elem_of_intersection X Y (x : A) : x X Y x X x Y;
elem_of_difference X Y (x : A) : x X Y x X x Y
elem_of_difference X Y (x : A) : x X Y x X x Y;
elem_of_intersection_with (f : A A option A) X Y (x : A) :
x intersection_with f X Y x1 x2, x1 X x2 Y f x1 x2 = Some x
}.
(** We axiomative a finite collection as a collection whose elements can be
......@@ -448,10 +485,12 @@ Inductive NoDup {A} : list A → Prop :=
(** Decidability of equality of the carrier set is admissible, but we add it
anyway so as to avoid cycles in type class search. *)
Class FinCollection A C `{ElemOf A C} `{Empty C} `{Union C}
`{Intersection C} `{Difference C} `{Singleton A C}
`{Elements A C} `{ x y : A, Decision (x = y)} := {
Class FinCollection A C `{ElemOf A C} `{Empty C} `{Singleton A C}
`{Union C} `{Intersection C} `{Difference C} `{IntersectionWith A C}
`{Filter A C} `{Elements A C} `{ x y : A, Decision (x = y)} := {
fin_collection :>> Collection A C;
elem_of_filter X P `{ x, Decision (P x)} x :
x filter P X P x x X;
elements_spec X x : x X x elements X;
elements_nodup X : NoDup (elements X)
}.
......@@ -471,13 +510,13 @@ Class CollectionMonad M `{∀ A, ElemOf A (M A)}
`{ A, Empty (M A)} `{ A, Singleton A (M A)} `{ A, Union (M A)}
`{!MBind M} `{!MRet M} `{!FMap M} `{!MJoin M} := {
collection_monad_simple A :> SimpleCollection A (M A);
elem_of_bind {A B} (f : A M B) (x : B) (X : M A) :
elem_of_bind {A B} (f : A M B) (X : M A) (x : B) :
x X = f y, x f y y X;
elem_of_ret {A} (x y : A) :
x mret y x = y;
elem_of_fmap {A B} (f : A B) (x : B) (X : M A) :
elem_of_fmap {A B} (f : A B) (X : M A) (x : B) :
x f <$> X y, x = f y y X;
elem_of_join {A} (x : A) (X : M (M A)) :
elem_of_join {A} (X : M (M A)) (x : A) :
x mjoin X Y, x Y Y X
}.
......@@ -520,6 +559,24 @@ Definition fst_map {A A' B} (f : A → A') (p : A * B) : A' * B :=
(f (fst p), snd p).
Definition snd_map {A B B'} (f : B B') (p : A * B) : A * B' :=
(fst p, f (snd p)).
Arguments fst_map {_ _ _} _ !_ /.
Arguments snd_map {_ _ _} _ !_ /.
Instance: {A A' B} (f : A A'),
Injective (=) (=) f Injective (=) (=) (@fst_map A A' B f).
Proof.
intros ????? [??] [??]; simpl; intro; f_equal.
* apply (injective f). congruence.
* congruence.
Qed.
Instance: {A B B'} (f : B B'),
Injective (=) (=) f Injective (=) (=) (@snd_map A B B' f).
Proof.
intros ????? [??] [??]; simpl; intro; f_equal.
* congruence.
* apply (injective f). congruence.
Qed.
Definition prod_relation {A B} (R1 : relation A) (R2 : relation B) :
relation (A * B) := λ x y, R1 (fst x) (fst y) R2 (snd x) (snd y).
......
......@@ -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.