Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

Is it possible to get a exact cover solution(s) and/or number of possible solutions in Mathematica?

share|improve this question
    
I saw the link. But can you bring us some toy code example? –  Murta Dec 8 '12 at 22:03
    
Pentomino tiling is one of classic tasks of exact cover algorithm: en.wikipedia.org/wiki/Exact_cover#Pentomino_tiling –  Dennis Yurichev Dec 8 '12 at 22:12
    
Pentomino tiling is a task of 2 subtasks: 1) generate all possible pentomino placement in matrix, e.g., generate list of matrices as a result; 2) exact cover algorithm to find all possible pentomino packings. Is it possible to solve in Mathematica? –  Dennis Yurichev Dec 8 '12 at 22:29
    
Is that similar to this? –  Rojo Dec 8 '12 at 23:44
    
Rojo, no, they solve that task by other methods, but thanks for your link! –  Dennis Yurichev Dec 8 '12 at 23:49

2 Answers 2

up vote 5 down vote accepted

Edit: Corrected the transcription of the solution, in final line.


This is one way to find Exact Cover solutions. It exploits the simple fact that non-disjoint (overlapping) subsets cannot be together in an exact cover solution, which must constitute a partition of the set x. My approach is almost certainly not the most efficient way, but it was how I was able to make sense the problem, which was new for me.

Data

Using the example from Wikipedia Exact Cover entry, where x constitutes the set and a..f constitute the subsets of x to consider.

x = Range[7];
a = {1, 4, 7};
b = {1, 4};
c = {4, 5, 7};
d = {3, 5, 6};
e = {2, 3, 6, 7};
f = {2, 7};
y = {a, b, c, d, e, f};

Array of Subsets and their elements

The first array plot displays the elements of x (column headers) contained by the subsets (row headers).

f1[rr_] := Flatten[{# -> 1} & /@ rr];
array = ReplacePart[ConstantArray[0, Length[x]], #] & /@ (f1 /@ y);
t = Transpose[{Range[6],  CharacterRange["a", FromCharacterCode[96 + Length[y]]]}];

MatrixPlot[array, Mesh -> True, FrameTicks -> {{t, t}, {Range[7], Range[7]}}]

The following array shows the elements of x in each subset, a..f.

array1

Compatibility Relations Between Subsets

Subset a is compatible with subset b if their intersection is empty, i.e if they are disjoint.

a2 = Array[Boole[Intersection[y[[#1]], y[[#2]]] == {}] &, {6, 6}];
MatrixPlot[a2, Mesh -> True, FrameTicks -> {{t, t}, {t, t}}]
compatibleSets = Flatten[Position[#, 1]] & /@ a2;

Candidates are possible exact cover solutions (together with the row subset). We generate the subsets and then prepend the row subset. If the row subset is not in a solution, then all candidates from the row will be rejected. However, all solutions will emerge elsewhere, i.e from candidates in other rows.

candidates = Rest@Subsets[#] & /@ compatibleSets;
c5 = Union[Flatten[Transpose[{candidates, Range[6]}] /. {l_, n_Integer} :>   
  (Sort[Prepend[#, n]] & /@ l), 1]]

Casesrequires that the candidates (plus header subset) have as many elements as x and that those elements be the same ones as in x.

Cases[c5,  z_ /; (Total[Length /@ (y[[#]] & /@ z)] == Length[x]) && 
   Union[Flatten[(y[[#]] & /@ z)]] == x]

If a subset shares no elements with another subset, it is compatible with it. For example, "a" is compatible with "d". "Compatible" is perhaps misleading since the compatibility relation, aRb, is commutative, but neither transitive nor reflexive! So it's important to "read the row information" as being a statement about what that subsets the row header subset is compatible with. One can not assume that all highlighted (orange) subsets in a row are mutually compatible.

We acknowledge that the numbers beneath the array plot below actually represent subsets (whereas in the first matrix plot, the numbers represented elements of the set, x). E.g. {1,4} stands for the fact that a is compatible with d. If I had patience, I would have the code return letters rather that digits that refer to the position in y.

a3

{{1, 4}, {2, 4}, {2, 5}, {2, 6}, {4, 6}, {1, 2, 4}, {1, 4, 6}, {2, 4, 5}, {2, 4, 6}, {2, 5,6}, {1, 2, 4, 6}, {2, 4, 5, 6}}

{{2, 4, 6}}

Note that only 12 candidate solutions needed to actually be checked out of a possible 128. {2,4,6}, that is, {b, d, f}, constitutes the only exact cover for the data (although this is not proven here).

This last line is sloppy; still needs to be automatized. Its only purpose is to convert digits to the subsets they stand for.

{"a", "b", "c", "d", "e", "f"}[[{2, 4, 6}]]

{"b","d","f"}

Checking that {b,d,f} is an exact cover.

Union[Join[b, d, f]] == x

True

share|improve this answer

I will use David Carraher's example to illustrate a way using integer linear programming.

x = Range[7];
a[1] = {1, 4, 7};
a[2] = {1, 4};
a[3] = {4, 5, 7};
a[4] = {3, 5, 6};
a[5] = {2, 3, 6, 7};
a[6] = {2, 7};

First we turn these subsets into 0-1 sets (think of them as bitvectors) representing whether a given element is in or not. For purposes of later using vector dot products I will transpose it. Could probably avoid that using MapIndexed later, or some such.

f[vec_, n_] := Table[If[MemberQ[vec, j], 1, 0], {j, n}]
b = Transpose@Table[f[a[j], 7], {j, 6}]

(* {{1, 1, 0, 0, 0, 0}, {0, 0, 0, 0, 1, 1}, {0, 0, 0, 1, 1, 
  0}, {1, 1, 1, 0, 0, 0}, {0, 0, 1, 1, 0, 0}, {0, 0, 0, 1, 1, 0}, {1, 
  0, 1, 0, 1, 1}} *)

We create a variable for each subset and restrict values to be zero (don't use that subset) or one (use it).

vars = Array[c, 6];
c1 = Map[0 <= # <= 1 &, vars];
c2 = Map[(#*(vars.b[[#]]) == #) &, x];

Here is thatsecond constraint set. The idea is that sums of boolean c elements times each j times bit vector elements for item j in corresponding subsets must give exactly j. (I'd like to believe that I stated that correctly. I don't believe it. But I'd like to.)

(* {c[1] + c[2] == 1, 2 (c[5] + c[6]) == 2, 
 3 (c[4] + c[5]) == 3, 4 (c[1] + c[2] + c[3]) == 4, 
 5 (c[3] + c[4]) == 5, 6 (c[4] + c[5]) == 6, 
 7 (c[1] + c[3] + c[5] + c[6]) == 7} *)

I use Reduce to find all solutions, then post-process to show each as a list of sublists, with sublist of the form {subset number, subset}.

Reduce[Join[c1, c2], vars, Integers] /. {Or -> List, 
  aa_ == 0 :> Sequence[], c[j_] == 1 :> {j, a[j]}, And -> List}

(* {{2, {1, 4}}, {4, {3, 5, 6}}, {6, {2, 7}}} *)
share|improve this answer
    
Nice. There's lots for me to learn from your example –  David Carraher Dec 10 '12 at 1:52

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.