Color: Graph Coloring
Preliminaries: Representing Graphs
The nodes in our graph will be named by positive numbers.
FSets and FMaps are interfaces for sets and maps over an element type.
One instance is when the element type is positive, with a particular
comparison operator corresponding to easy lookup in tries. The
Coq module for this element type (with its total order) is PositiveOrderedTypeBits.
We'll use E as an abbreviation for this module name.
The Module Type FSetInterface.S gives the API of "functional sets."
One instance of this, PositiveSet, has keys = positive numbers. We
abbreviate this as Module S.
And similarly for functional maps over positives
Lemmas About Sets and Maps
Module WF := WFacts_fun E M. Module WP := WProperties_fun E M. Print Module WF.
Print Module WP.
Check E.lt.
E.lt is a comparison predicate on positive numbers. It
is not the usual less-than operator; it is a different ordering
that is more compatible with the order that a Positive Trie arranges
its keys. In the application of certain lemmas about maps and sets,
we will need the facts that E.lt is a StrictOrder (irreflexive and
transitive) and respects a congruence over equality (is Proper
for eq ==> eq ==> iff). As shown here, we just have to dig up
these facts from a submodule of a submodule of a submodule of M.
Lemma lt_strict: StrictOrder E.lt.
Proof. exact M.ME.MO.IsTO.lt_strorder. Qed.
Lemma lt_proper: Proper (eq ==> eq ==> iff) E.lt.
Proof. exact M.ME.MO.IsTO.lt_compat. Qed.
The domain of a map is the set of elements that map to Some(_). To calculate
the domain, we can use M.fold, an operation that comes with the FMaps
abstract data type. It takes a map m, function f and base value b, and calculates
f x1 y1 (f x2 y2 (f x3 y3 (... (f xn yn b)...))), where (xi,yi) are the individual elements
of m. That is, M.find xi m = Some yi, for each i.
So, to compute the domain, we just use an f function that adds xi to a set;
mapping this over all the nodes will add all the keys in m to the set S.empty.
Example: Make a map from node (represented as positive) to
set of node (represented as S.t), in which nodes 3,9,2 each map
to the empty set, and no other nodes map to anything.
Definition example_map : M.t S.t :=
(M.add 3%positive S.empty
(M.add 9%positive S.empty
(M.add 2%positive S.empty (M.empty S.t )))).
Example domain_example_map:
S.elements (Mdomain example_map) = [2;9;3]%positive.
Proof. compute. reflexivity. Qed.
Suppose two lists al,bl both contain the same elements, not necessarily in the same
order. That is, forall x:A, In x al <-> In x bl. In fact from this definition you can
see that al or bl might even have different numbers of repetitions of certain
elements. Then we say the lists are "equivalent."
We can generalize this. Suppose instead of In x al, which says that the value x
is in the list al, we use a different equivalence relation on that A. That is,
InA eqA x al says that some element of al is equivalent to x, using the
equivalence relation eqA. For example:
Definition same_mod_10 (i j: nat) := i mod 10 = j mod 10.
Example InA_example: InA same_mod_10 27 [3;17;2].
Proof. right. left. compute. reflexivity. Qed.
The predicate equivlistA eqA al bl says that lists al and bl have equivalent
sets of elements, using the equivalence relation eqA. For example:
Example equivlistA_example: equivlistA same_mod_10 [3; 17] [7; 3; 27].
Proof.
split; intro.
inv H. right; left. auto.
inv H1. left. apply H0.
inv H0.
inv H. right; left. apply H1.
inv H1. left. apply H0.
inv H0. right. left. apply H1.
inv H1.
Qed.
SortA_equivlistA_eqlistA
Suppose two lists al,bl are "equivalent:" they contain the same set of elements (modulo an equivalence relation eqA on elements, perhaps in different orders, and perhaps with different numbers of repetitions). That is, suppose equivlistA eqA al bl.
That is, suppose eqA is an equivalence relation on type A, that is,
eqA is reflexive, symmetric, and transitive. And suppose ltA is a strict order,
that is, irreflexive and transitive. And suppose ltA respects the equivalence
relation, that is, if eqA x x' and eqA y y', then ltA x y <-> ltA x' y'.
THEN, if l is sorted (using the comparison ltA), and l' is sorted,
and l,l' contain equivalent sets of elements, then l,l' must be equal lists,
modulo the equivalence relation.
To make this easier to think about, let's use ordinary equality for eqA.
We will be making sets and maps over the "node" type, E.t, but that's just
type positive. Therefore, the equivalence E.eq: E.t -> E.t -> Prop is just
the same as eq.
Lemma eqlistA_Eeq_eq: forall al bl, eqlistA E.eq al bl <-> al=bl.
Proof.
split; intro.
* induction H. reflexivity. unfold E.eq in H. subst. reflexivity.
* subst. induction bl. constructor. constructor.
unfold E.eq. reflexivity. assumption.
Qed.
Lemma SortE_equivlistE_eqlistE:
forall al bl, Sorted E.lt al ->
Sorted E.lt bl ->
equivlistA E.eq al bl -> eqlistA E.eq al bl.
Proof.
apply SortA_equivlistA_eqlistA; auto.
apply lt_strict.
apply lt_proper.
Qed.
If list l is sorted, and you apply List.filter to remove the elements on which
f is false, then the result is still sorted. Obviously.
Lemma filter_sortE: forall f l,
Sorted E.lt l -> Sorted E.lt (List.filter f l).
Proof.
apply filter_sort with E.eq; auto.
apply lt_strict.
apply lt_proper.
Qed.
S.remove and S.elements
The FSets interface (and therefore our Module S) provides these two functions:
In module S, of course, S.elt=positive, as these are sets of positive numbers.
Now, this relationship between S.remove and S.elements will soon be useful:
Lemma Sremove_elements: forall (i: E.t) (s: S.t),
S.In i s ->
S.elements (S.remove i s) =
List.filter (fun x => if E.eq_dec x i then false else true) (S.elements s).
Abort.
That is, if i is in the set s, then the elements of S.remove i s is the
list that you get by filtering i out of S.elements s. Go ahead and prove it!
Exercise: 3 stars (Sremove_elements)
Lemma Proper_eq_eq:
forall f, Proper (E.eq ==> @eq bool) f.
Proof.
unfold Proper. unfold respectful.
Admitted.
Lemma Sremove_elements: forall (i: E.t) (s: S.t),
S.In i s ->
S.elements (S.remove i s) =
List.filter (fun x => if E.eq_dec x i then false else true) (S.elements s).
Proof.
intros.
apply eqlistA_Eeq_eq.
apply SortE_equivlistE_eqlistE.
*
admit.
*
admit.
*
intro j.
rewrite filter_InA; [ | apply Proper_eq_eq].
destruct (E.eq_dec j i).
+
admit.
+
admit.
Admitted.
forall f, Proper (E.eq ==> @eq bool) f.
Proof.
unfold Proper. unfold respectful.
Admitted.
Lemma Sremove_elements: forall (i: E.t) (s: S.t),
S.In i s ->
S.elements (S.remove i s) =
List.filter (fun x => if E.eq_dec x i then false else true) (S.elements s).
Proof.
intros.
apply eqlistA_Eeq_eq.
apply SortE_equivlistE_eqlistE.
*
admit.
*
admit.
*
intro j.
rewrite filter_InA; [ | apply Proper_eq_eq].
destruct (E.eq_dec j i).
+
admit.
+
admit.
Admitted.
☐
Lists of (key,value) Pairs
Let's start with a little lemma about lists of pairs: Suppose l: list (positive*A).
Then j is in map fst l iff there is some e such that (j,e) is in l.
Exercise: 2 stars (InA_map_fst_key)
Lemma InA_map_fst_key:
forall A j l,
InA E.eq j (map (@fst M.E.t A) l) <-> exists e, InA (@M.eq_key_elt A) (j,e) l.
Admitted.
forall A j l,
InA E.eq j (map (@fst M.E.t A) l) <-> exists e, InA (@M.eq_key_elt A) (j,e) l.
Admitted.
☐
Exercise: 3 stars (Sorted_lt_key)
The function M.lt_key compares two elements of an M.elements list, that is, two pairs of type positive*A, by just comparing their first elements using E.lt. Therefore, an elements list (of type list(positive*A) is Sorted by M.lt_key iff its list-of-first-elements is Sorted by E.lt.Lemma Sorted_lt_key:
forall A (al: list (positive*A)),
Sorted (@M.lt_key A) al <-> Sorted E.lt (map (@fst positive A) al).
Proof.
Admitted.
☐
Cardinality
Exercise: 4 stars (cardinal_map)
Hint: To prove this theorem, I used these lemmas.
You might find a different way.
Check M.cardinal_1.
Check M.elements_1.
Check M.elements_2.
Check M.elements_3.
Check map_length.
Check eqlistA_length.
Check SortE_equivlistE_eqlistE.
Check InA_map_fst_key.
Check WF.map_mapsto_iff.
Check Sorted_lt_key.
Admitted.
Lemma Sremove_cardinal_less: forall i s,
S.In i s -> S.cardinal (S.remove i s) < S.cardinal s.
Proof.
intros.
repeat rewrite S.cardinal_1.
generalize (Sremove_elements _ _ H); intro.
rewrite H0; clear H0.
Admitted.
S.In i s -> S.cardinal (S.remove i s) < S.cardinal s.
Proof.
intros.
repeat rewrite S.cardinal_1.
generalize (Sremove_elements _ _ H); intro.
rewrite H0; clear H0.
Admitted.
☐
We have a lemma SortA_equivlistA_eqlistA that talks about
arbitrary equivalence relations and arbitrary total-order relations
(as long as they are compatible. Here is a specialization to
a particular equivalence (M.eq_key_elt) and order (M.lt_key).
Lemma specialize_SortA_equivlistA_eqlistA:
forall A al bl,
Sorted (@M.lt_key A) al ->
Sorted (@M.lt_key A) bl ->
equivlistA (@M.eq_key_elt A) al bl ->
eqlistA (@M.eq_key_elt A) al bl.
Proof.
intros.
apply SortA_equivlistA_eqlistA with (@M.lt_key A); auto.
apply M.eqke_equiv.
apply M.ltk_strorder.
clear.
repeat intro.
unfold M.lt_key, M.eq_key_elt in *.
destruct H, H0. rewrite H,H0. split; auto.
Qed.
Lemma Proper_eq_key_elt:
forall A,
Proper (@M.eq_key_elt A ==> @M.eq_key_elt A ==> iff)
(fun x y : E.t * A => E.lt (fst x) (fst y)).
Proof.
repeat intro. destruct H,H0. rewrite H,H0. split; auto.
Qed.
Lemma Mremove_elements: forall A i s,
M.In i s ->
eqlistA (@M.eq_key_elt A) (M.elements (M.remove i s))
(List.filter (fun x => if E.eq_dec (fst x) i then false else true) (M.elements s)).
Check specialize_SortA_equivlistA_eqlistA.
Check M.elements_1.
Check M.elements_2.
Check M.elements_3.
Check M.remove_1.
Check M.eqke_equiv.
Check M.ltk_strorder.
Check Proper_eq_key_elt.
Check filter_InA.
Admitted.
M.In i s ->
eqlistA (@M.eq_key_elt A) (M.elements (M.remove i s))
(List.filter (fun x => if E.eq_dec (fst x) i then false else true) (M.elements s)).
Check specialize_SortA_equivlistA_eqlistA.
Check M.elements_1.
Check M.elements_2.
Check M.elements_3.
Check M.remove_1.
Check M.eqke_equiv.
Check M.ltk_strorder.
Check Proper_eq_key_elt.
Check filter_InA.
Admitted.
Lemma Mremove_cardinal_less: forall A i (s: M.t A), M.In i s ->
M.cardinal (M.remove i s) < M.cardinal s.
M.cardinal (M.remove i s) < M.cardinal s.
Look at the proof of Sremove_cardinal_less, if you succeeded
in that, for an idea of how to do this one.
Admitted.
Lemma fold_right_rev_left:
forall (A B: Type) (f: A -> B -> A) (l: list B) (i: A),
fold_left f l i = fold_right (fun x y => f y x) i (rev l).
Admitted.
Lemma Snot_in_empty: forall n, ~ S.In n S.empty.
Admitted.
This seems so obvious! But I didn't find a really simple proof of it.
Admitted.
☐
Definition node := E.t.
Definition nodeset := S.t.
Definition nodemap: Type -> Type := M.t.
Definition graph := nodemap nodeset.
Definition adj (g: graph) (i: node) : nodeset :=
match M.find i g with Some a => a | None => S.empty end.
Definition undirected (g: graph) :=
forall i j, S.In j (adj g i) -> S.In i (adj g j).
Definition no_selfloop (g: graph) := forall i, ~ S.In i (adj g i).
Definition nodes (g: graph) := Mdomain g.
Definition subset_nodes
(P: node -> nodeset -> bool)
(g: graph) :=
M.fold (fun n adj s => if P n adj then S.add n s else s) g S.empty.
A node has "low degree" if the cardinality of its adjacency set is less than K
Definition low_deg (K: nat) (n: node) (adj: nodeset) : bool := S.cardinal adj <? K.
Definition remove_node (n: node) (g: graph) : graph :=
M.map (S.remove n) (M.remove n g).
Some Proofs in Support of Termination
We need to prove some lemmas related to the termination of the algorithm before we can actually define the Function.Exercise: 3 stars (subset_nodes_sub)
Lemma select_terminates:
forall (K: nat) (g : graph) (n : S.elt),
S.choose (subset_nodes (low_deg K) g) = Some n ->
M.cardinal (remove_node n g) < M.cardinal g.
Admitted.
forall (K: nat) (g : graph) (n : S.elt),
S.choose (subset_nodes (low_deg K) g) = Some n ->
M.cardinal (remove_node n g) < M.cardinal g.
Admitted.
☐
Require Import Recdef.
Function select (K: nat) (g: graph) {measure M.cardinal g}: list node :=
match S.choose (subset_nodes (low_deg K) g) with
| Some n => n :: select K (remove_node n g)
| None => nil
end.
Proof. apply select_terminates.
Defined.
Definition coloring := M.t node.
Definition colors_of (f: coloring) (s: S.t) : S.t :=
S.fold (fun n s => match M.find n f with Some c => S.add c s | None => s end) s S.empty.
Definition color1 (palette: S.t) (g: graph) (n: node) (f: coloring) : coloring :=
match S.choose (S.diff palette (colors_of f (adj g n))) with
| Some c => M.add n c f
| None => f
end.
Definition color (palette: S.t) (g: graph) : coloring :=
fold_right (color1 palette g) (M.empty _) (select (S.cardinal palette) g).
Function select (K: nat) (g: graph) {measure M.cardinal g}: list node :=
match S.choose (subset_nodes (low_deg K) g) with
| Some n => n :: select K (remove_node n g)
| None => nil
end.
Proof. apply select_terminates.
Defined.
Definition coloring := M.t node.
Definition colors_of (f: coloring) (s: S.t) : S.t :=
S.fold (fun n s => match M.find n f with Some c => S.add c s | None => s end) s S.empty.
Definition color1 (palette: S.t) (g: graph) (n: node) (f: coloring) : coloring :=
match S.choose (S.diff palette (colors_of f (adj g n))) with
| Some c => M.add n c f
| None => f
end.
Definition color (palette: S.t) (g: graph) : coloring :=
fold_right (color1 palette g) (M.empty _) (select (S.cardinal palette) g).
Proof of Correctness of the Algorithm.
Definition coloring_ok (palette: S.t) (g: graph) (f: coloring) :=
forall i j, S.In j (adj g i) ->
(forall ci, M.find i f = Some ci -> S.In ci palette) /\
(forall ci cj, M.find i f = Some ci -> M.find j f = Some cj -> ci<>cj).
Lemma in_colors_of_1:
forall i s f c, S.In i s -> M.find i f = Some c -> S.In c (colors_of f s).
Admitted.
forall i s f c, S.In i s -> M.find i f = Some c -> S.In c (colors_of f s).
Admitted.
Theorem color_correct:
forall palette g,
no_selfloop g ->
undirected g ->
coloring_ok palette g (color palette g).
Admitted.
forall palette g,
no_selfloop g ->
undirected g ->
coloring_ok palette g (color palette g).
Admitted.
☐
That concludes the proof that the algorithm is correct.
Local Open Scope positive.
Definition palette: S.t := fold_right S.add S.empty [1; 2; 3].
Definition add_edge (e: (E.t*E.t)) (g: graph) : graph :=
M.add (fst e) (S.add (snd e) (adj g (fst e)))
(M.add (snd e) (S.add (fst e) (adj g (snd e))) g).
Definition mk_graph (el: list (E.t*E.t)) :=
fold_right add_edge (M.empty _) el.
Definition G :=
mk_graph [ (5,6); (6,2); (5,2); (1,5); (1,2); (2,4); (1,4)].
Compute (S.elements (Mdomain G)).
Compute (M.elements (color palette G)).
That is our graph coloring: Node 4 is colored with color 1, node 2 with color 3,
nodes 6 and 1 with 2, and node 5 with color 1.