Re: Sudoku puzzle
- To: mathgroup at smc.vnet.net
- Subject: [mg58386] Re: Sudoku puzzle
- From: "Simons, F.H." <F.H.Simons at tue.nl>
- Date: Thu, 30 Jun 2005 04:37:21 -0400 (EDT)
- Sender: owner-wri-mathgroup at wolfram.com
Last weekend in a Dutch newspaper I saw a small article about sudoku's.
I thought this was a nice exercise in backtracking with Mathematica, so
I wrote a short program for finding sudoku's.
Then, to my surprise, in mathgroup some contributions were devoted to
sudoku's. So I cannot resist the temptation to post my backtracking
solution.
The administration is done in a 9x9-matrix called possiblechoices. Each
entry contains a list of all possible choices for that position. Hence
initially the entries of this matrix are {1,2,...9}.
The sudoku under construction is the 9x9-matrix result. Initially all
entries are 0.
Most of the work is done by the function enterchoice[{i,j,n}]. It
manipulates both the matrices result and possiblechoices. The number i
is the row number, j is the column number and n is the value of the
entry. Of course this function may be applied only when n is an allowed
choice for the entry. In that case it reduces the possibilities for the
entries on the row, the column and the 3x3-block of (i,j) in the matrix
possiblechoices and it adapts the matrix result.
The backtracking is done in the folowing way. The entries with only one
possible choice can be filled at once. Having done that, we look for an
entry with a minimal number of choices, so at least 2 choices. We choose
the first element and place the rest on the list stilltobedone. Then we
continue in the same way until no further choices are possible. When we
found a sudoku, it is placed on the list of solutions. Then we proceed
with the last item on the list stilltobedone, etc, until this list is
empty.
sudokuForm[mat_] := DisplayForm[
GridBox[Map[GridBox, Partition[mat, {3, 3}],
{2}], GridFrame -> True, RowLines -> True,
ColumnLines -> True]]
sudokuQ[mat_] := And @@ Flatten[
{(Union[#1] == Range[9] & ) /@ mat,
(Union[#1] == Range[9] & ) /@ Transpose[mat],
Map[Union @@ #1 == Range[9] & ,
Partition[mat, {3, 3}], {2}]}]
enterchoice[{i_, j_, n_}] :=
Block[{}, If[MemberQ[possiblechoices[[i,j]], n],
possiblechoices[[i]] =
(DeleteCases[#1, n] & ) /@ possiblechoices[[
i]]; possiblechoices[[All,j]] =
(DeleteCases[#1, n] & ) /@ possiblechoices[[
All,j]]; possiblechoices =
MapAt[DeleteCases[#1, n] & ,
possiblechoices, Flatten[Outer[List,
Partition[Range[9], 3][[Ceiling[i/3]]],
Partition[Range[9], 3][[Ceiling[j/3]]]],
1]]; possiblechoices[[i,j]] = {};
result[[i,j]] = n, Return[possiblechoices =
testarray]]]
sudoku[mat_] := Block[{possiblechoices =
Array[Range[9] & , {9, 9}],
result = Array[0 & , {9, 9}],
stilltobedone = {}, testarray =
Array[{} & , {9, 9}], solutions = {}, z,
pos},
z = With[{z = Position[mat, _Integer?
Positive]}, Flatten /@ Transpose[
{z, Extract[mat, z]}]]; Scan[enterchoice,
z]; While[possiblechoices != testarray ||
stilltobedone != {},
z = Min[Map[Length, possiblechoices, {2}] /.
0 -> 10]; Which[z == 1,
z = With[{z = Position[possiblechoices,
{_}]}, Apply[Join, Transpose[
{z, Extract[possiblechoices, z]}],
{1}]]; Scan[enterchoice, z], z < 10,
With[{pos = Position[possiblechoices,
_?(Length[#1] == z & )][[1]]},
AppendTo[stilltobedone, ReplacePart[
possiblechoices, Rest[
(possiblechoices[[##1]] & ) @@ pos],
pos]]; possiblechoices = ReplacePart[
possiblechoices, Take[
(possiblechoices[[##1]] & ) @@ pos,
1], pos]], True,
possiblechoices = stilltobedone[[-1]];
stilltobedone = Most[stilltobedone]];
If[sudokuQ[result],
AppendTo[solutions, result]]];
solutions]
Regards,
Fred Simons
Eindhoven University of Technology