## Solving Sudoku With a Functional Language

Solving Sudoku puzzles is usually considered a basic computer solving problem. While the task is not trivial there are a few complexities that have to be addressed. In this post I wanted to explore my first, and probably crude, attempt to solve the problem functionally using Mathematica. It should be noted that I am new to both Mathematica and functional languages in general. Also, my syntax highlighting doesn’t support Mathematica’s language.

First, let’s define the problem space as a 9×9 grid of digits but lets index them using a four coordinate system using [puzzle-row, puzzle-col, cell-row, cell-col]. So, a coordinate of [1,2,1,1] would mean the top-center grid and the top-left most cell in that grid. With that we can define all possible coordinates as…

allCoordinates = Tuples[Array[Range@3 &, 4]]; |

allCoordinates = Tuples[Array[Range@3 &, 4]];

Next define all “related” coordinates. By this I mean all coordinates affected by the value in a particular cell. So, all cells in the same sub puzzle plus any along the target row or column; note the use of “memoization” for performance…

relatedCoordinates[{pr_, pc_, cr_, cc_}] := relatedCoordinates[{pr, pc, cr, cc}] = Level[#, {-2}] &@({{pr, pc, #1, #2}, {pr, #1, cr, #2}, {#1, pc, #2, cc}} & @@@ Tuples[Array[Range@3 &, 2]]) |

relatedCoordinates[{pr_, pc_, cr_, cc_}] := relatedCoordinates[{pr, pc, cr, cc}] = Level[#, {-2}] &@({{pr, pc, #1, #2}, {pr, #1, cr, #2}, {#1, pc, #2, cc}} & @@@ Tuples[Array[Range@3 &, 2]])

I approached this problem by taking a blank puzzle and applying my test puzzle to it one cell at a time. I define a cell as having two possible type of values: lists of possible values, or a single assigned value. Therefor a blank puzzle is nothing but a set of cells containing all possible digits…

blankPuzzle[{pr_, pc_, cr_, cc_}] := Range[9]; |

blankPuzzle[{pr_, pc_, cr_, cc_}] := Range[9];

Now for the functional magic. Handling state has been a challenge to me but this solution seems elegant. The applyValue method simply takes a function that reads a puzzle, along with a coordinate and a new value to assign. From that it creates a new function that mostly just refers to the passed in function for values, but with two key differences. First, the coordinate passed in is “hard wired” to the new value. Second, all “related coordinates” that are lists have the passed in value removed from their list of possible values…

applyValue[p_, {c_, 0}] := p; applyValue[p_, {c_, v_}] := Module[{f}, f[t_] := p[t]; f[c] = v; (f[#] = Select[ p[#], # != v &]) & /@ Select[relatedCoordinates[c], (Head[p[#]] == List && # != c) &]; f]; |

applyValue[p_, {c_, 0}] := p; applyValue[p_, {c_, v_}] := Module[{f}, f[t_] := p[t]; f[c] = v; (f[#] = Select[ p[#], # != v &]) & /@ Select[relatedCoordinates[c], (Head[p[#]] == List && # != c) &]; f];

Now the process is fairly simple. First, take a blank puzzle and apply all known values recursively. Note that 0’s don’t get applied in the above applyValue logic. In this case 0 simply represents a blank cell…

primePuzzle[p_] := Module[{}, Fold[applyValue, blankPuzzle, {#, p[[Sequence @@ #]]} & /@ allCoordinates] ]; |

primePuzzle[p_] := Module[{}, Fold[applyValue, blankPuzzle, {#, p[[Sequence @@ #]]} & /@ allCoordinates] ];

Finally, the solve puzzle method is rather similar to the procedural solution. First, if there are no unknowns then the puzzle is solved. Next, find any unknowns and attempt solve the cell with the least set of possibilities. If any cell has no possible values then of no solutions are found by substitution, backtrack and try again…

solvePuzzle[p_] := Module[{unknowns = Select[#, Head[Last[#]] == List &] &@({#, p[#]} & /@ allCoordinates), target, solutions}, If[Length[unknowns] == 0, Return[p]]; target = unknowns[[First[Ordering[Length[Last[#]] & /@ unknowns]]]]; If[Length[Last@target] == 0, Return[Null]]; solutions = Select[solvePuzzle[applyValue[p, {First@target, #}]] & /@ Last@target, ! (# === Null) &, 1]; If[Length[solutions] == 1, First[solutions], Null] ]; |

solvePuzzle[p_] := Module[{unknowns = Select[#, Head[Last[#]] == List &] &@({#, p[#]} & /@ allCoordinates), target, solutions}, If[Length[unknowns] == 0, Return[p]]; target = unknowns[[First[Ordering[Length[Last[#]] & /@ unknowns]]]]; If[Length[Last@target] == 0, Return[Null]]; solutions = Select[solvePuzzle[applyValue[p, {First@target, #}]] & /@ Last@target, ! (# === Null) &, 1]; If[Length[solutions] == 1, First[solutions], Null] ];

Solving a puzzle is then simply…

solvePuzzle@primePuzzle@puzzles |

solvePuzzle@primePuzzle@puzzles

Nov 16, 2013aewhite**Category:** General, Programming Read more
No Comments

Comments are closed.