Sudoku

Author

Eric W. Weisstein
October 2, 2007

This notebook downloaded from http://mathworld.wolfram.com/notebooks/RecreationalMath/Sudoku.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/Sudoku.html.

©2007 Wolfram Research, Inc. except for portions noted otherwise

Additional Authors

SudokuSolve (using knapsack method) by 
Dan Lichtblau
Aug. 19, 2005

SudokuSolveSimons by 
Fred Simons
2005

Code

SudokuPlot[s_List,m_List?MatrixQ]:=Module[{n=Length[m],c=First/@s},
Graphics[{
{If[Mod[#,Sqrt[n]]==0,Thickness[.01],Sequence@@{}],
{Line[{{#,0},{#,n}}],Line[{{0,#},{n,#}}]}}&/@Range[0,n],
MapIndexed[{If[MemberQ[c,#2],Red,Sequence@@{}],Text[#1,{#2[[2]],n+1-#2[[1]]}-1/2]}&,m,{2}]
},AspectRatio->Automatic]
]
SudokuPlot[s_List]:=Module[{n=Max[Flatten[First/@s]]},
Graphics[{
{If[Mod[#,Sqrt[n]]==0,Thickness[.01],Sequence@@{}],
{Line[{{#,0},{#,n}}],Line[{{0,#},{n,#}}]}}&/@Range[0,n],
Red,Text[#[[2]],{#[[1,2]],n+1-#[[1,1]]}-1/2]
}&/@s,AspectRatio->Automatic
]
]

SudokuSolve[data_,d_,diags_:False]:=Module[{x,vars,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,constraints,known,stack,counter=0,fvars,soln,val,badpos,lmax,varvals,n=d^3,eps=10^(-2),sd=Sqrt[d],newvars,j1,k1,removables,augment,newknown,others,changed,lhs,rhs,mat,solvvars,rules={},var,maxval},vars=Array[x,{d,d,d}];
fvars=Flatten[vars];
c2=Table[Total[vars[[All,j,k]]]==1,{j,d},{k,d}];
c3=Table[Total[vars[[j,All,k]]]==1,{j,d},{k,d}];
c4=Table[Total[vars[[j,k,All]]]==1,{j,d},{k,d}];
c5=Table[Sum[vars[[j,k+k2*sd,m+m2*sd]],{k,sd},{m,sd}]==1,{k2,0,sd-1},{m2,0,sd-1},{j,d}];
c6=If[diags,{Table[Sum[vars[[k,j,j]],{j,d}]==1,{k,d}],Table[Sum[vars[[k,j,d-j+1]],{j,d}]==1,{k,d}]},(*else*){}];
c7=Map[Table[x[j,#[[1,1]],#[[1,2]]]->If[j==#[[2]],1,0],{j,d}]&,data];
c8=Map[Table[x[#[[2]],j,#[[1,2]]]->If[j==#[[1,1]],1,0],{j,d}]&,data];
c9=Map[Table[x[#[[2]],#[[1,1]],j]->If[j==#[[1,2]],1,0],{j,d}]&,data];
c10=Map[(j1=sd*Quotient[#[[1,1]]-1,sd];
k1=sd*Quotient[#[[1,2]]-1,sd];
Table[x[#[[2]],j,k]->If[j==#[[1,1]]&&k==#[[1,2]],1,0],{j,j1+1,j1+sd},{k,k1+1,k1+sd}])&,data];
known=Dispatch[Union[Flatten[{c7,c8,c9,c10}]]];
constraints=Flatten[({c2,c3,c4,c5,c6}/.known)/.True->Sequence[]];
newvars=Complement[fvars,Variables[known[[1]]/.Rule->List]];
constraints=Flatten[Join[constraints,Map[0≤#≤1&,newvars]/.known]/.True->Sequence[]];
If[Length[newvars]==0,Return[{0,Table[vars[[All,j,k]].Range[d],{j,d},{k,d}]/.rules/.known}]];
stack={constraints,{}};
(*main branching loop*)While[stack=!={},constraints=First[stack];
stack=Last[stack];
counter++;
Quiet[soln=NMaximize[{1,constraints},newvars]];
If[!FreeQ[soln,Indeterminate],Continue[]];
{maxval,soln}=soln;
varvals=Chop[newvars/.soln];
badpos=0;
lmax=0;
Do[If[(val=Abs[varvals[[j]]-Round[varvals[[j]]]])≥eps,If[val>lmax,lmax=val;badpos=j]],{j,Length[newvars]}];
If[badpos==0,soln=soln/.aa_Real:>Round[aa];
soln=Table[vars[[All,j,k]].Range[d],{j,d},{k,d}]/.rules/.soln/.known;
Return[soln];,(*else*)stack={Append[constraints,newvars[[badpos]]==1-Round[varvals[[badpos]]]],stack};
stack={Append[constraints,newvars[[badpos]]==Round[varvals[[badpos]]]],stack};];];
{}]

sudokuForm[mat_] :=
With[{order = Sqrt[Dimensions[mat][[1]]]},
Grid[mat, GridFrame -> True,
RowLines -> Array[If[Mod[#, order] == 0, True, False] &, {order^2}],
ColumnLines -> Array[If[Mod[#, order] == 0, True, False] &, {order^2}]]]

enternumber[{i_, j_, n_}, order_:3, extra_:""] := Block[{},
If[Not[MemberQ[possiblechoices[[i, j]], n]],
Throw[possiblechoices = {}; False]];
possiblechoices[[i, j]] = {};
possiblechoices[[i]] =
If[# == {n}, Throw[possiblechoices = {}; False], DeleteCases[#, n]] & /@
possiblechoices[[i]];
possiblechoices[[All, j]] =
If[# == {n}, Throw[possiblechoices = {}; False], DeleteCases[#, n]] & /@
possiblechoices[[All, j]];
possiblechoices =
MapAt[If[# == {n}, Throw[possiblechoices = {}; False],
DeleteCases[#, n]] &, possiblechoices,
Flatten[Outer[List,
Partition[Range[order^2], order] [[Ceiling[i/order]]],
Partition[Range[order^2], order] [[Ceiling[j/order]]]], 1]];
If[(extra == "both" || extra == "diagonal") && i == j,
possiblechoices =
MapAt[If[# == {n}, Throw[possiblechoices = {}; False],
DeleteCases[#, n]] &, possiblechoices,
Table[{k, k}, {k, 1, order^2}]]];
If[(extra == "both" || extra == "antidiagonal") && i + j == order^2 + 1,
possiblechoices =
MapAt[If[# == {n}, Throw[possiblechoices = {}; False],
DeleteCases[#, n]] &, possiblechoices,
Table[{k, order^2 + 1 - k}, {k, 1, order^2}]]];
result[[i, j]] = n]

singlechoice[v_] := With[{u = Flatten[Cases[Split[Sort[Flatten[v]]], {_}]]},
If[Length[u] > 1 && Max[Length[Intersection[u, #]] & /@ v] > 1,
Throw[possiblechoices = {}; False],
If[Length[u] > 0,
ReplacePart[v, List /@ u, (Position[v, #] & /@ u)[[All, All, 1]],
List /@ Range[Length[u]]], v]
]]

reduce1[v : {__List}, n_Integer:2] :=
Block[{t = True, z, res = v, inv = Count[v, {}]},
While[t,
z = Split[Sort[Cases[res, Table[_, {n}]]]];
If[Max[Length /@ z] > n, Throw[possiblechoices = {}; False]];
z = Select[First /@ Select[z, Length[#] == n &],
Function[lst, Or @@ (Count[Flatten[res], #] > n & /@ lst)]];
If[z == {}, t = False,
z = z[[1]];
res = If[# != z, Complement[#, z], #] & /@ res;
If[Count[res, {}] != inv, Throw[possiblechoices = {}; False]],
t = False]];
res]

reduce2[v_, n_:2] := Block[{u, res},
u = Select[Union @@ v, Count[Flatten[v], #] == n &];
If[Length[u] >= n,
u = {#[[1, 1]], #[[All, -1]]} & /@
Select[Split[
Sort[Transpose[{#[[All, 1]] & /@ (Position[v, #] &) /@ u, u}]],
Equal @@ {##}[[All, 1]] &], Length[#] == n &];
u = Select[u, Max[Length[v[[#]]] & /@ #[[1]]] > n &] ;
If[Length[u] > 0, res = v;
(res[[#[[1]]]] = Table[#[[2]], {n}]) & /@ u;
res, v],
v]]

reduce[v_] :=
FixedPoint[
Function[z,
z // singlechoice // (reduce1[#, 2] &) // (reduce2[#,
2] &) // (reduce1[#, 3] &) // (reduce2[#, 3] &)], v]

SudokuSolveSimons[mat_, n : (_Integer | Infinity) : 1,
report : (True | False) : True, extra_String:""] :=
Block[{possiblechoices,
result,
stilltobedone = {},
solutions = {},
order, z, pos,
counter = 0},

(* initialisation *)
order = Sqrt[Dimensions[mat][[1]]];
possiblechoices = Array[Range[order^2] & , {order^2, order^2}];
result = Array[0 & , {order^2, order^2}];
Catch[
Scan[enternumber[#, order, extra] &,
With[{z = Position[mat // Normal, _Integer?Positive]},
Flatten /@ Transpose[{z, Extract[mat, z]}]
]]];
stilltobedone = {possiblechoices};
possiblechoices = {};

(* loop *)
While[stilltobedone != {} && Length[solutions] < n,
counter++;
possiblechoices = stilltobedone[[-1]];
stilltobedone = Most[stilltobedone];

While[ Flatten[possiblechoices] != {} ,
Catch[
(* lists of length 1 ****************************************)
While[(z = Position[possiblechoices, {_}]) != {},

Scan[enternumber[#, order, extra] &,
Apply[Join,
Transpose[{z, Extract[possiblechoices, z]}], {1}]]];

If[Flatten[possiblechoices] != {},
(*reduction ********************************************)

(* rows *)
Do[ possiblechoices[[i]] = reduce[possiblechoices[[i]]],
{i, 1, order^2}];

(* columns *)
Do[ possiblechoices[[All, i]] =
reduce[possiblechoices[[All, i]]], {i, 1, order^2}];

(* blocks *)
z = Flatten[#, 1] & /@
Flatten[Partition[possiblechoices, {order, order}], 1];
Do[ z[[i]] = reduce[z[[i]]], {i, 1, order^2}];
possiblechoices =
Flatten[MapThread[Join, ##] & /@
Partition[(Partition[#, order] &) /@ z, order], 1];

(* diagonal *)
If[extra == "diagonal" || extra == "both",
z = reduce[Table[possiblechoices[[i, i]], {i, 1, order^2}]];
Do[possiblechoices[[i, i]] = z[[i]], {i, 1, order^2}]];

(* antidiagonal *)
If[extra == "antidiagonal" || extra == "both",
z = reduce[
Table[possiblechoices[[i, order^2 + 1 - i]], {i, 1,
order^2}]];
Do[possiblechoices[[i, order^2 + 1 - i]] = z[[i]], {i, 1,
order^2}]];

(*
backtracking **********************************)
If[Cases[possiblechoices, {_}, {2}] == {},
z = Min[Map[Length, possiblechoices, {2}] /. 0 -> order^2 + 1];
z = Position[possiblechoices, _?(Length[#] == z &)];
pos = {{0, 0}, 3 order^2};
Do[With[{m =
Count[possiblechoices[[z[[i, 1]]]], {}] +
Count[possiblechoices[[All, z[[i, 2]]]], {}] +
Count[Extract[possiblechoices,
Flatten[
Outer[List,
Partition[Range[order^2],
order] [[Ceiling[z[[i, 1]]/order]]],
Partition[Range[order^2],
order] [[Ceiling[z[[i, 2]]/order]]]],
1]], {}]},
If[m < pos[[2]], pos = {z[[i]], m}]], {i, 1, Length[z]}];
pos = pos[[1]];
AppendTo[stilltobedone,
ReplacePart[possiblechoices,
Rest[possiblechoices[[##]] & @@ pos], pos]];
possiblechoices =
ReplacePart[possiblechoices,
Take[possiblechoices[[##]] & @@ pos, 1], pos]
] ] ]
];

(* test solution ***********************************)

If[And @@ Flatten[{Length[Union[#1]] == order^2 & /@ result,
Length[Union[#1]] == order^2 & /@ Transpose[result],

Map[Length[Union @@ #1] == order^2 & ,
Partition[result, {order, order}], {2}],
If[extra == "both" || extra == "diagonal",
Length[Union[Table[result[[i, i]], {i, 1, order^2}]]] ==
order^2, {}],

If[extra == "both" || extra == "antidiagonal",
Length[Union[Table[result[[i, i]], {i, 1, order^2}]]] ==
order^2, {}]}],
AppendTo[solutions, result]]
];

(* result ************************************)
If[report,
Print[If[counter == 1, "Solved without backtracking.",
"Looked at " <> ToString[counter] <> " situations."]]];
If[n == 1 && solutions != {}, sudokuForm[solutions[[1]]],
sudokuForm /@ solutions]
]

Flights

San Diego -> Champaign 8/13/2008

Gentle

s=(({{\[Placeholder], \[Placeholder], 5, \[Placeholder], \[Placeholder], 8, 1, \[Placeholder], \[Placeholder]}, {\[Placeholder], 8, \[Placeholder], \[Placeholder], \[Placeholder], 4, 7, 9, \[Placeholder]}, {\[Placeholder], \[Placeholder], \[Placeholder], \[Placeholder], 3, \[Placeholder], \[Placeholder], \[Placeholder], \[Placeholder]}, {8, \[Placeholder], 2, \[Placeholder], \[Placeholder], 5, \[Placeholder], \[Placeholder], 3}, {\[Placeholder], \[Placeholder], 3, \[Placeholder], \[Placeholder], \[Placeholder], 2, \[Placeholder], \[Placeholder]}, {5, \[Placeholder], \[Placeholder], 6, \[Placeholder], \[Placeholder], 4, \[Placeholder], 8}, {\[Placeholder], \[Placeholder], \[Placeholder], \[Placeholder], 1, \[Placeholder], \[Placeholder], \[Placeholder], \[Placeholder]}, {\[Placeholder], 3, 6, 9, \[Placeholder], \[Placeholder], \[Placeholder], 7, \[Placeholder]}, {\[Placeholder], \[Placeholder], 8, 5, \[Placeholder], \[Placeholder], 3, \[Placeholder], \[Placeholder]}}));

s9=DeleteCases[Flatten[MapIndexed[#2->#1&,s,{2}],1],_->\[Placeholder]]

SudokuPlot[s9]

SudokuPlot[s9,m9=SudokuSolve[s9,9]]

Themed

By Ed Pegg, Jr.
Oct. 2, 2007

s9={{1,2}->7,{1,4}->8,{2,1}->1,{2,3}->2,{2,5}->3,{2,9}->9,{3,1}->4,{3,3}->5,{3,5}->6,{4,1}->6,{4,3}->1,{4,5}->4,{6,5}->7,{6,7}->3,{6,9}->2,{7,5}->2,{7,7}->9,{7,9}->8,{8,1}->7,{8,5}->1,{8,7}->6,{8,9}->3,{9,6}->9,{9,8}->2};

SudokuPlot[s9]

Timing[m9=SudokuSolve[s9,9]]

Show[SudokuPlot[s9 ,m9],TextStyle->{FontFamily->"Times"}]

9x9

TMJ9, No. 3 Puzzle

s9={{1,2}->3,{1,4}->9,{1,8}->8,{2,3}->6,{2,4}->2,{2,6}->3,{2,7}->7,{2,8}->9,{3,4}->1,{4,2}->2,{4,4}->3,{4,8}->7,{5,5}->7,{5,8}->6,{5,9}->4,{6,1}->1,{7,2}->5,{7,6}->4,{7,7}->9,{8,2}->7,{8,3}->2,{9,2}->9,{9,5}->5,{9,7}->8,{9,8}->3};

Timing[m9=SudokuSolve[s9,9]]

Normal[SparseArray[s9]]

SudokuSolveSimons[Normal[SparseArray[s9]],9]//Timing

Equal[Union[Union/@m9],Union[Union/@Transpose[m9]],{Range[9]}]

Show[GraphicsArray[Block[{$DisplayFunction=Identity},
{
Show[SudokuPlot[s9],TextStyle->{FontFamily->"Times"}],
Show[SudokuPlot[s9,m9],TextStyle->{FontFamily->"Times"}]
}]],ImageSize->500]

16-Clue with exactly two solutions

clues16={{1,1}->1,{1,9}->5,{2,5}->3,{3,3}->2,{3,5}->4,{5,2}->3,{5,3}->4,{5,7}->7,{6,4}->2,{6,6}->6,{6,9}->1,{7,1}->2,{7,6}->5,{8,2}->7,{8,8}->3,{9,6}->1};

SudokuSolveSimons[Normal[SparseArray[clues16]],9]//Timing

Timing[m9=SudokuSolve[clues16,9]]

Show[SudokuPlot[clues16],TextStyle->{FontFamily->"Times",FontSize->18}]

Sample Case

s9={{1,2}->3,{1,7}->9,{2,3}->6,{3,4}->2,{3,5}->4,{3,6}->1,{3,8}->3,{4,4}->9,{4,7}->7,{5,6}->2,{5,9}->4,{6,2}->8,{6,5}->7,{6,8}->2,{7,1}->8,{7,2}->5,{8,2}->9,{8,4}->7,{8,6}->4,{9,6}->6,{9,9}->1};

SudokuSolveSimons[Normal[SparseArray[s9]],9]//Timing

Timing[m9=SudokuSolve[s9,9]]

Show[GraphicsArray[Block[{$DisplayFunction=Identity},
{
Show[SudokuPlot[s9],TextStyle->{FontFamily->"Times"}],
Show[SudokuPlot[s9 ,m9],TextStyle->{FontFamily->"Times"}]
}]],ImageSize->500]

NYT, May 1, 2006

s9={{1,1}->8,{1,4}->7,{1,5}->5,{1,9}->3,{2,2}->3,{2,5}->4,{2,6}->8,{2,8}->2,{3,1}->1,{3,9}->6,{4,1}->3,{4,2}->4,{4,5}->7,{4,9}->8,{5,1}->7,{5,2}->9,{5,4}->4,{5,5}->8,{5,8}->3,{5,9}->1,{6,1}->2,{6,3}->8,{6,8}->7,{6,9}->4,{7,1}->5,{7,4}->8,{7,5}->1,{7,6}->4,{7,9}->7,{8,2}->8,{8,4}->3,{8,5}->2,{8,6}->7,{8,8}->4,{9,1}->4,{9,4}->5,{9,5}->6,{9,6}->9,{9,9}->2};

SudokuPlot[s9]//Show

SudokuSolveSimons[Normal[SparseArray[s9]],9]//Timing

Timing[m9=SudokuSolve[s9,9]]

Show[GraphicsArray[Block[{$DisplayFunction=Identity},
{
Show[SudokuPlot[s9],TextStyle->{FontFamily->"Times"}],
Show[SudokuPlot[s9 ,m9],TextStyle->{FontFamily->"Times"}]
}]],ImageSize->500]

16×16

s16={{1,2}->10,{1,5}->16,{1,8}->14,{1,13}->15,{1,14}->13,{2,2}->11,{2,3}->6,{2,5}->2,{2,7}->1,{2,10}->4,{2,14}->9,{3,12}->12,{3,16}->7,{4,1}->13,{4,6}->10,{4,11}->15,{4,13}->5,{4,14}->3,{4,15}->8,{5,4}->8,{5,5}->6,{5,8}->11,{5,9}->4,{5,10}->3,{5,12}->14,{6,2}->15,{6,7}->8,{6,8}->2,{6,9}->13,{6,13}->14,{6,14}->1,{6,15}->4,{7,3}->16,{7,4}->7,{7,6}->5,{7,10}->1,{7,14}->2,{7,16}->13,{8,2}->14,{8,5}->12,{8,9}->16,{8,10}->9,{8,11}->10,{9,6}->13,{9,7}->7,{9,8}->3,{9,12}->4,{9,15}->11,{10,1}->5,{10,3}->12,{10,7}->15,{10,11}->8,{10,13}->10,{10,14}->14,{11,2}->2,{11,3}->9,{11,4}->14,{11,8}->10,{11,9}->3,{11,10}->16,{11,15}->12,{12,5}->14,{12,7}->4,{12,8}->5,{12,9}->1,{12,12}->6,{12,13}->16,{13,2}->16,{13,3}->13,{13,4}->9,{13,6}->8,{13,11}->14,{13,16}->6,{14,1}->12,{14,5}->10,{15,3}->4,{15,7}->9,{15,10}->11,{15,12}->7,{15,14}->15,{15,15}->3,{16,3}->1,{16,4}->3,{16,9}->5,{16,12}->2,{16,15}->7};

SudokuSolveSimons[Normal[SparseArray[s16]],16]//Timing

Timing[m16=SudokuSolve[s16,16]]

Show[SudokuPlot[s16,m16]]