Graph Colouring

/*
 * Graph Colouring
 *   A graph is represented by a list, each item of which is of the form
 *   g(V,Ns), where V is a vertex, and Ns is a list of its neighbours.
 *   The graph colouring problem is to find a smallest set of colours such
 *   that when each vertex of a graph is assigned a colour from the set,
 *   no two neighboring vertices are assigned the same colour
 */

/* colour(Graph, NumberOfColours, VVs) is true if for the Vertex of each   */
/*   element g(Vertex,Neighbours) of the Graph the corresponding element   */
/*   of VVs is vv(Vertex,Colour) where Colour is an integer between 1 and  */
/*   NumberOfColours, such that no two adjacent vertices have the same     */
/*   Colour. On backtracking, all solutions will be found.                 */
/* e.g. colour([g(1,[2]),g(2,[1,3,4]),g(3,[2,4]),g(4,[2,3])], 3,           */
/*             [vv(2,1),vv(4,2),vv(3,3),vv(1,2)]).                         */
colour(Graph, NumberOfColours, VVs):-
  quicksort(Graph, SortedGraph), % Sort by decreasing number of neighbours
                                 % This is the "largest-degree heuristic"
  integers(1, NumberOfColours, Colours),
  initialize_domains(SortedGraph, Colours, VDs),
  fc(VDs, VVs).

/* quicksort(Xs, Ys) is true if Ys is a sorted permutation of the list Xs. */
quicksort(Xs, Ys):-quicksort_1(Xs, Ys, []).

quicksort_1([], Ys, Ys).
quicksort_1([X|Xs], Ys, Zs):-
  partition(Xs, X, Ms, Ns),
  quicksort_1(Ns, Ws, Zs),
  quicksort_1(Ms, Ys, [X|Ws]).

partition([], _, [], []).
partition([L|Ls], X, Ms, [L|Ns]):-
  L=g(_,Vs),
  X=g(_,Ws),
  is_shorter(Vs, Ws), !, % Sort by decreasing number of neighbours
  partition(Ls, X, Ms, Ns).
partition([L|Ls], X, [L|Ms], Ns):-
  partition(Ls, X, Ms, Ns).

/* is_shorter(Xs, Ys) is true if the list Xs contains fewer elements than  */
/*   the list Ys.                                                          */
is_shorter([], [_|_]).
is_shorter([_|Xs], [_|Ys]):-is_shorter(Xs, Ys).

initialize_domains([], _, []).
initialize_domains([G|Graph], Colours, [vd(G,Colours)|Domains_]):-
  initialize_domains(Graph, Colours, Domains_).

/* fc(VDs, VVs) is true if for each element vd(g(Vertex,Neighbours),Di) of */
/*   VDs the corresponding element of VVs is vv(Vertex,Colour) where       */
/*   Colour is an element of Di, such that no two adjacent vertices have   */
/*   the same Colour. On backtracking, all solutions will be found.        */
fc([], []).
fc([vd(g(Vertex,Neighbours),Domain)|VDs], [vv(Vertex,Colour)|VVs]):-
  member(Colour, Domain),
  update_domains(Neighbours, Colour, VDs, VDs1),
  fc(VDs1, VVs).

/* update_domains(Neighbours, Colour, VDs0, VDs) is true if: each element  */
/*   vd(Xh,Dk) of VDs is the same as the corresponding element vd(Xh,Dh)   */
/*   of VDs0 except that Colour is removed from Dh if Xh is a member of    */
/*   Neighbours; and no domain Dk is empty.                                */
update_domains([], _, VDs, VDs).
update_domains([Neighbour|Neighbours], Colour, VDs0, VDs):-
  update_domain(VDs0, Neighbour, Colour, VDs1),
  update_domains(Neighbours, Colour, VDs1, VDs).

/* update_domain(VDs0, Vertex, Colour, VDs) is true if: each element       */
/*   vd(Xh,Dk) of VDs is the same as the corresponding element vd(Xh,Dh)   */
/*   of VDs0 except that Colour is removed from Dh if Xh equals Vertex;    */
/*   and no domain Dk is empty.                                            */
update_domain([], _, _, []).
update_domain([VD0|VDs0], Vertex, Colour, [vd(V,Domain)|VDs0]):-
  VD0=vd(V,Domain0),
  V=g(Vertex,_),
  !,
  delete(Domain0, Colour, Domain),
  Domain=[_|_].
update_domain([VD|VDs0], Vertex, Colour, [VD|VDs]):-
  update_domain(VDs0, Vertex, Colour, VDs).

/* delete(Ys, X, Zs) is true if Zs is the result of removing the first     */
/*   occurrence of the element X from the list Ys.                         */
delete([], _, []).
delete([X|Ys], X, Ys):-!.
delete([Y|Ys], X, [Y|Zs]):-delete(Ys, X, Zs).

/* integers(M, N, Is) is true if Is is the list of integers from M to N    */
/*   inclusive.                                                            */
integers(N, N, [N]):-!.
integers(I, N, [I|Is]):-I < N, I1 is I + 1, integers(I1, N, Is).

/* member(X, Xs) is true if the element X is contained in the list Xs.     */
%member(X, [X|_]).
%member(X, [_|Xs]):-member(X, Xs).

LPA Index     Home Page