Set Covering Problem - Greedy Algorithms

/*
 * Random greedy algorithm:
 * At each iteration the variable that appears in the largest number of
 * unsatisfied constraints is picked, ties being broken randomly. When all
 * constraints are satisfied, redundant variables are discarded one at a
 * time, the order being chosen randomly.
 */

/* greedy(+Constraints, -Cover) is true if Cover is an ordered subset of   */
/*   the set of variables contained in the Constraints such that each      */
/*   constraint (an ordered set) has at least one variable in common with  */
/*   Cover. Note that the obtained Cover may not be minimal, and several   */
/*   runs may be necessary to obtain a minimal cover.                      */
/* e.g. greedy([[2,3,5],[2,4,5,8,10],[2,5,10],[7,8],[3,5,10]], X)          */
/*   will give X=[5,7] or X=[5,8].                                         */
greedy(Constraints, Cover):-
  variables(Constraints, [], Variables),
  greedy_1(Constraints, Variables, [], Cover1),
  findall(Dummy, redundant(Cover1, Constraints, Dummy), RedundantVariables),
  remove_redundant(RedundantVariables, Constraints, Cover1, Cover).

greedy_1([], _, Cover, Cover):-!.
greedy_1(Constraints, Variables, Cover0, Cover):-
  satisfactions(Variables, Constraints, 0, MaxN, Ns),
  candidates(Variables, Ns, MaxN, Candidates),
  rand_member(Candidates, Selected),
  update(Constraints, Selected, Constraints1),
  ord_insert(Cover0, Selected, Cover1),
  remove(Selected, Variables, Variables1), !,
  greedy_1(Constraints1, Variables1, Cover1, Cover).

variables([], Vs, Vs).
variables([Xs|Xss], Vs0, Vs):-
  variables_1(Xs, Vs0, Vs1),
  variables(Xss, Vs1, Vs).

variables_1([], Vs, Vs).
variables_1([X|Xs], Vs0, Vs):-
  \+ ord_member(X, Vs0), !,
  ord_insert(Vs0, X, Vs1),
  variables_1(Xs, Vs1, Vs).
variables_1([_|Xs], Vs0, Vs):-
  variables_1(Xs, Vs0, Vs).

/* update(Constraints0, Variable, Constraints) is true if Constraints is   */
/*   the result of removing from Constraints0 all constraints satisfied    */
/*   by the Variable.                                                      */
/* e.g. update([[0,1],[0,2],[1,2],[0,3],[1,3]], 0, [[1,2],[1,3]]).         */
update([], _, []).
update([Constraint|Constraints0], Variable, [Constraint|Constraints]):-
  \+ ord_member(Variable, Constraint), !,
  update(Constraints0, Variable, Constraints).
update([_|Constraints0], Variable, Constraints):-
  update(Constraints0, Variable, Constraints).

/* redundant(Cover, Constraints, Variable) is true if the Variable         */
/*   (contained in Cover) is a redundant variable with respect to the      */
/*   Constraints.  On backtracking, all such variables will be found.      */
redundant(Cover, Constraints, Variable):-
  remove(Variable, Cover, Cover1),
  is_cover(Constraints, Cover1).

/* remove_redundant(RedundantVariables, Constraints, Cover0, Cover) is     */
/*   true if Cover is the result of removing redundant variables from      */
/*   Cover0 with respect to the Constraints, where RedundantVariables is   */
/*   the initial list of redundant variables.                              */
remove_redundant([], _, Cover, Cover):-!.
remove_redundant(RedundantVariables, Constraints, Cover0, Cover):-
  rand_member(RedundantVariables, RedundantVariable),
  remove(RedundantVariable, Cover0, Cover1), !,
  findall(Dummy,
          redundant(Cover1, Constraints, Dummy),
          RedundantVariables1),
  remove_redundant(RedundantVariables1, Constraints, Cover1, Cover).

/*
 * Random alternating greedy algorithm:
 * At each iteration two steps are performed. First, the variable that
 * appears in the largest number (N) of as yet unsatisfied constraints is
 * added to the solution, ties being broken randomly. Then, any number of
 * variables may be discarded from the solution, as long as the total number
 * of constraints that become unsatisfied is less than N. In particular, any
 * variable that becomes redundant after the addition of the variable is
 * discarded. The variables to be discarded are chosen greedily, according to
 * lexicographic order. Note that a variable may be discarded from the
 * solution and then picked again in a later iteration. This algorithm solves
 * some problems that the random greedy algorithm doesn't solve.
 */

/* alt_greedy(+Constraints, -Cover) is true if Cover is an ordered subset  */
/*   of the set of variables contained in the Constraints such that each   */
/*   constraint (an ordered set) has at least one variable in common with  */
/*   Cover. Note that the obtained Cover may not be minimal, and several   */
/*   runs may be necessary to obtain a minimal cover.                      */
/* e.g. alt_greedy([[2,3,5],[2,4,5,8,10],[2,5,10],[7,8],[3,5,10]], X)      */
/*   will give X=[5,7] or X=[5,8].                                         */
alt_greedy(Constraints, Cover):-
  variables(Constraints, [], Variables),
  alt_greedy_1(Constraints, [], Variables, [], Cover),
  is_cover(Constraints, Cover). /* Debug - check the solution */

alt_greedy_1([], _, _, AssVars, AssVars):-!.
alt_greedy_1(Unsats, Sats, UnassVars, AssVars0, AssVars):-
  satisfactions(UnassVars, Unsats, 0, MaxN, Ns),
  candidates(UnassVars, Ns, MaxN, Candidates),
  rand_member(Candidates, Selected),
  ord_insert(AssVars0, Selected, AssVars1),
  update_add(Unsats, Sats, Selected, Unsats1, Sats1),
  discard(MaxN, AssVars1, Unsats1, Sats1, AssVars2, Unsats2, Sats2),
  ord_diff(AssVars0, AssVars2, Vars),
  remove(Selected, UnassVars, UnassVars1), !,
  ord_union(Vars, UnassVars1, UnassVars2),
  alt_greedy_1(Unsats2, Sats2, UnassVars2, AssVars2, AssVars).

/* satisfactions(Variables, Constraints, 0, Max, Satisfactions) is true if */
/*   each element of Satisfactions is the number of Constraints which      */
/*   would be satisfied by the corresponding element of Variable (or       */
/*   0 if the number is less than a previous element), and Max is the      */
/*   maximum element of Satisfactions.                                     */
/* e.g. satisfactions([2,3,4], [[1,2],[2,3],[1,4]], 0, 2, [2,0,0]).        */
satisfactions([], _, Max, Max, []).
satisfactions([Variable|Variables], Constraints, Max0, Max, [N|Ns]):-
  covered(Constraints, Variable, 0, N),
  N >= Max0, !,
  satisfactions(Variables, Constraints, N, Max, Ns).
satisfactions([_|Variables], Constraints, Max0, Max, [0|Ns]):-
  satisfactions(Variables, Constraints, Max0, Max, Ns).

/* candidates(Variables, Satisfactions, Value, Candidates) is true if      */
/*   Candidates is that subset of Variables such that the corresponding    */
/*   element of Satisfactions is equal to Value.                           */
/* e.g. candidates([2,3,4], [3,1,3], 3, [2,4]).                            */
candidates([], [], _, []).
candidates([Variable|Variables], [N|Ns], N, [Variable|Candidates]):-!,
  candidates(Variables, Ns, N, Candidates).
candidates([_|Variables], [_|Ns], N, Candidates):-
  candidates(Variables, Ns, N, Candidates).

/* covered(Xss, Y, 0, N) is true if N is the number of elements of Xss of  */
/*   which Y is a member.                                                  */
/* e.g. covered([[1,2],[1,3],[1,4],[2,3],[2,4],[3,4]], 4, 0, 3).           */
covered([], _, N, N).
covered([Xs|Xss], Y, N0, N):-
  ord_member(Y, Xs), !,
  N1 is N0 + 1,
  covered(Xss, Y, N1, N).
covered([_|Xss], Y, N0, N):-
  covered(Xss, Y, N0, N).

/* uncovered(Xss, Ys, 0, N) is true if N is the number of elements of Xss  */
/*   which have no elements in common with Ys.                             */
/* e.g. uncovered([[1,2],[1,3],[1,4],[2,3],[2,4],[3,4]], [1,2], 0, 1).     */
uncovered([], _, N, N).
uncovered([Xs|Xss], Ys, N0, N):-
  \+ ord_joint(Ys, Xs), !, /* Faster than \+ ord_joint(Xs, Ys) */
  N1 is N0 + 1,
  uncovered(Xss, Ys, N1, N).
uncovered([_|Xss], Ys, N0, N):-
  uncovered(Xss, Ys, N0, N).

/* update_add(Unsats0, Sats0, Variable, Unsats, Sats) is true if Unsats is */
/*   the result of removing from Unsats0 all constraints satisfied by the  */
/*   Variable, and Sats is the result of adding to Sats0 all constraints   */
/*   satisfied by the Variable.                                            */
/* e.g. update_add([[1,2],[1,3],[1,4],[2,3],[2,4],[3,4]], [], 2,           */
/*                 Unsats, Sats).                                          */
update_add([], Sats, _, [], Sats).
update_add([Unsat|Unsats0], Sats0, Variable, [Unsat|Unsats], Sats):-
  \+ ord_member(Variable, Unsat), !,
  update_add(Unsats0, Sats0, Variable, Unsats, Sats).
update_add([Sat|Unsats0], Sats0, Variable, Unsats, Sats):-
  update_add(Unsats0, [Sat|Sats0], Variable, Unsats, Sats).

/* update_discard(Sats0, Unsats0, Variables, Sats, Unsats) is true if Sats */
/*   is the result of removing from Sats0 all constraints not satisfied by */
/*   the Variables, and Unsats is the result of adding to Unsats0 all      */
/*   constraints satisfied by the Variables.                               */
/* e.g. update_discard([[1,2],[1,3],[1,4],[2,3],[2,4],[3,4]], [], [2],     */
/*                     Sats, Unsats).                                      */
update_discard([], Unsats, _, [], Unsats).
update_discard([Unsat|Sats0], Unsats0, Variables, Sats, Unsats):-
  \+ ord_joint(Variables, Unsat), !,
  update_discard(Sats0, [Unsat|Unsats0], Variables, Sats, Unsats).
update_discard([Sat|Sats0], Unsats0, Variables, [Sat|Sats], Unsats):-
  update_discard(Sats0, Unsats0, Variables, Sats, Unsats).

/* discard(N, Vs0, Unsats0, Sats0, Vs, Unsats, Sats) is true if N is the   */
/*   maximum number of constraints to become unsatisfied, Vs0 is the       */
/*   current list of assigned variables, Unsats0 is the current list of    */
/*   unsatisfied constraints, Sats0 is the current list of satisfied       */
/*   constraints, Vs is the new list of assigned variables after zero or   */
/*   more discards, Unsats is the list of constraints unsatisfied by Vs,   */
/*   and Sats is the list of constraints satisfied by Vs.                  */
/* e.g. discard(4, [1,2,3], [], [[1,2],[1,3],[1,4],[2,3],[2,4],[3,4]],     */
/*              Vs, Unsats, Sats).                                         */
discard(N, Vs0, Unsats0, Sats0, Vs, Unsats, Sats):-
  N > 0,
  best(Vs0, Vs0, Sats0, 32767, P, 0, Best),
  P < N,
  remove(Best, Vs0, Vs1), !,
  update_discard(Sats0, Unsats0, Vs1, Sats1, Unsats1),
  N2 is N - P,
  discard(N2, Vs1, Unsats1, Sats1, Vs, Unsats, Sats).
discard(_, Vs, Unsats, Sats, Vs, Unsats, Sats).

/* best(Vs, Vs, Constrs, 32767, N, 0, Best) is true if Vs is the current   */
/*   list of assigned variables, Constrs is the list of constraints        */
/*   satisfied by Vs, and Best is that member of Vs which, if discarded,   */
/*   would cause the least number, N, of constraints in Constrs to become  */
/*   unsatisfied.                                                          */
/* e.g. best([1,2], [1,2], [[1,2],[1,3],[1,4],[2,3]], 32767, 1, 0, 2).     */
best([], _, _, N, N, Best, Best).
best([V|Vs], Vs0, Constrs, N0, N, _, Best):-
  remove(V, Vs0, Vs1),
  uncovered(Constrs, Vs1, 0, N1),
  N1 < N0, !,
  best(Vs, Vs0, Constrs, N1, N, V, Best).
best([_|Vs], Vs0, Constrs, N0, N, Best0, Best):-
  best(Vs, Vs0, Constrs, N0, N, Best0, Best).

/*
 * Library procedures
 */

/* is_cover(Xss, Ys) is true if at least one element of Ys is contained in */
/*   each element of Xss.                                                  */
/* e.g. is_cover([[1,2],[1,3],[1,4],[2,3],[2,4],[3,4]], [1,2,3]).          */
is_cover([], _).
is_cover([Xs|Xss], Ys):-
  ord_joint(Xs, Ys),
  is_cover(Xss, Ys).

/* ord_diff(Set1, Set2, Difference) is true if Set1 and Set2 are the       */
/*   ordered representations of two sets and Difference is unified with    */
/*   the ordered representation of their difference.  Set1 and Set2 must   */
/*   be sufficiently instantiated and in standard order.                   */
ord_diff([], _, []).
ord_diff([X|Xs], [], [X|Xs]).
ord_diff([X|Xs], [X|Ys], Ds):-
  !, ord_diff(Xs, Ys, Ds).
ord_diff([X|Xs], [Y|Ys], [X|Ds]):-
  X < Y, !, ord_diff(Xs, [Y|Ys], Ds).
ord_diff([X|Xs], [_|Ys], Ds):-
  ord_diff([X|Xs], Ys, Ds).

/* ord_insert(Xs, Y, Zs) is true if Zs is the ordered list resulting from  */
/*   inserting Y into the ordered list Xs, without duplicates.             */
ord_insert([Y|Xs], Y, [Y|Xs]):-!.
ord_insert([X|Xs], Y, [X|Ws]):-X < Y, !, ord_insert(Xs, Y, Ws).
ord_insert(Xs, Y, [Y|Xs]).

/* ord_joint(Xs, Ys) is true if the ordered lists Xs and Ys have at least  */
/*   one common element.                                                   */
/* e.g. ord_joint([3,4], [1,2,3]).                                         */
ord_joint([X|_], [X|_]):-!.
ord_joint([X|Xs], [Y|Ys]):-X < Y, !, ord_joint(Xs, [Y|Ys]).
ord_joint([X|Xs], [_|Ys]):-ord_joint([X|Xs], Ys).

/* ord_member(X, Ys) is true if X is a member of the ordered list Ys.      */
/* e.g. ord_member(3, [2,3,4]).                                            */
ord_member(X, [X|_]):-!.
ord_member(X, [Y|Xs]):-Y < X, ord_member(X, Xs).

/* ord_union(+Set1, +Set2, ?Union) is true if Set1 and Set2 are the        */
/*   ordered representations of two sets and Union is unified with the     */
/*   ordered representation of their union.  Set1 and Set2 must be         */
/*   sufficiently instantiated and in standard order.                      */
ord_union([], Ys, Ys).
ord_union([X|Xs], [], [X|Xs]).
ord_union([X|Xs], [X|Ys], [X|Zs]):-!,
  ord_union(Xs, Ys, Zs).
ord_union([X|Xs], [Y|Ys], [X|Zs]):-
  X < Y, !, ord_union(Xs, [Y|Ys], Zs).
ord_union([X|Xs], [Y|Ys], [Y|Zs]):-
  ord_union([X|Xs], Ys, Zs).

/* rand_int(I, J) is true if J is a pseudo-random non-negative integer     */
/*   less than I.                                                          */
rand_int(I, J):-I > 0, J is int(rand(I)).

/* rand_member(Xs, X) is true if X is a pseudo-randomly chosen member of   */
/*   the list Xs.                                                          */
rand_member(Xs, X):-
  length(Xs, M),
  rand_int(M, N),
  rand_member_1(Xs, X, 0, N).

rand_member_1([X|_], X, N, N):-!.
rand_member_1([_|Xs], X, N0, N):-
  N1 is N0 + 1,
  rand_member_1(Xs, X, N1, N).

/*
 * Sample application
 */
  
/* "Find a minimal subset of a set of words such that the words in the     */
/*    subset contain all the letters in the words in the set."             */
/*  Goal: solve([`january`,`february`,`march`,`april`,`may`,`june`,`july`, */
/*               `august`,`september`,`october`,`november`,`december`],    */
/*              Cover).                                                    */
solve(Words, Cover):-
  strings_chars(Words, Chars),
  chars_used_letters(Chars, [], Letters),
  data(Letters, Chars, Constraints),
%  greedy(Constraints, Cover0),
  alt_greedy(Constraints, Cover0),
  indexes(Cover0, Words, Cover).

strings_chars([], []).
strings_chars([String|Strings], [Cs|Css]):-
  string_chars(String, Cs),
  strings_chars(Strings, Css).
  
chars_used_letters([], Letters, Letters).  
chars_used_letters([Cs|Css], Letters0, Letters):-
  chars_used_letters_1(Cs, Letters0, Letters1),
  chars_used_letters(Css, Letters1, Letters).

chars_used_letters_1([], Letters, Letters).
chars_used_letters_1([Char|Chars], Letters0, Letters):-
  ord_insert(Letters0, Char, Letters1),
  chars_used_letters_1(Chars, Letters1, Letters).

data([], _, []).
data([Letter|Letters], Chars, [Constraint|Constraints]):-
  data_1(Chars, Letter, 0, Constraint),
  data(Letters, Chars, Constraints).

data_1([], _, _, []).
data_1([Cs|Css], Letter, I, [I|Constraint]):-
  member(Letter, Cs), !,
  I1 is I + 1,
  data_1(Css, Letter, I1, Constraint).
data_1([_|Css], Letter, I, Constraint):-
  I1 is I + 1,
  data_1(Css, Letter, I1, Constraint).
  
indexes([], _, []).
indexes([X|Xs], Y, [Z|Zs]):-
  nth(Y, X, Z),
  indexes(Xs, Y, Zs).
       
/* nth(Xs, N, X) is true if X is the N-th (base 0) element of the list Xs. */
nth(Xs, N, X):-nth_1(Xs, X, 0, N).

nth_1([X|_], X, I, I):-!.
nth_1([_|Xs], X, I0, I):-
  I1 is I0 + 1,
  nth_1(Xs, X, I1, I).

LPA Index     Home Page

Valid HTML 4.01 Strict