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