Sudoku
February 19, 2009
A simple solution is based on depth-first search. Input is a string of eighty-one characters representing a sudoku grid in row-major order, top-to-bottom and left-to-right, with a zero in empty cells; output is represented in the same form.
The sudoku puzzle is represented internally as two lists, empty and filled, which between them always contain eighty-one cells. Rows are numbered 0 through 8 from top to bottom, columns are numbered 0 through 8 from left to right, and boxes (three-by-three sub-grids) are numbered 0 through 8 from top-to-bottom, left-to-right, in row-major order. Digits are #\1 through #\9, plus # as a placeholder for a cell with a yet-unknown digit. The reader scans the input string left-to-right, with s indexing the characters of the string. The row, column and box are computed by arithmetic on the index s, and a four-slot vector representing the cell is created; then the cell is added to either the empty or filled list, as appropriate. When the entire string has been scanned the puzzle is passed to the solver.
The solver works by moving cells back and forth between the empty list and the filled list. At each iteration of the solve loop, the cell at the head of the empty list is examined. If a digit can be added at the current cell without violating any sudoku constraints, the solver advances by moving the cell from the empty list to the filled list. However, if no digit can safely be added at the current cell, the solver backtracks by clearing (resetting the digit to #) the top cell on the empty list and moving the head of the filled list back to the head of the empty list.
The inner loop of the solver is the try loop, which tries to place successive digits in the current cell. The cond expression has three clauses. The first clause backtracks when all possible digits have been considered, and the second clause advances when it is safe to place the digit in the current cell. The third clauses tries the next digit. The try and solve loops are intertwined, doing their work by twiddling cells back and forth between the empty and filled lists until digits have been safely placed in all eighty-one cells and the empty list is null.
The safe? function, which is called in the try loop, returns #t if digit can be placed in cell without violating any of the sudoku constraints, and #f otherwise. It works by scanning the filled list. If any cell on the filled list has the same row and digit as the prospective new cell, or the same column and digit, or the same box and digit, the prospective cell cannot be placed in the puzzle, and safe? returns #f. If the end of the filled list is reached without violating any of the constraints, the prospective cell can be placed in the puzzle, and safe? returns #t.
The solver uses two other utility functions. (next digit) calculates the successor to a digit, in the sequence #\1 to #\9. Note that the first successor is #\1 because the reader initializes empty cells with #; this is a fine example of the case where properly specifying the form of the input can affect the simplicity of the code. (new old digit) returns a newly-allocated cell with the row, column and box coordinates of the old cell and a new digit.
(define (sudoku puzzle)
(define (safe? filled digit cell)
(cond ((null? filled) #t)
((and (= (vector-ref (car filled) 0) (vector-ref cell 0))
(char=? (vector-ref (car filled) 3) digit)) #f)
((and (= (vector-ref (car filled) 1) (vector-ref cell 1))
(char=? (vector-ref (car filled) 3) digit)) #f)
((and (= (vector-ref (car filled) 2) (vector-ref cell 2))
(char=? (vector-ref (car filled) 3) digit)) #f)
(else (safe? (cdr filled) digit cell))))
(define (next digit) (integer->char (+ (char->integer digit) 1)))
(define (new old digit) (vector (vector-ref old 0) (vector-ref old 1) (vector-ref old 2) digit))
(let scan ((s 0) (empty '()) (filled '()))
(if (< s 81)
(let* ((row (quotient s 9))
(col (modulo s 9))
(box (+ (* (quotient row 3) 3) (quotient col 3)))
(digit (string-ref puzzle s))
(cell (vector row col box digit)))
(if (char=? digit #\0)
(scan (+ s 1) (cons cell empty) filled)
(scan (+ s 1) empty (cons cell filled))))
(let solve ((empty empty) (filled filled))
(if (pair? empty)
(let try ((cell (car empty)) (digit (next (vector-ref (car empty) 3))))
(cond ((char<? #\9 digit) ; backtrack
(solve (cons (car filled) (cons (new cell #\0) (cdr empty))) (cdr filled)))
((safe? filled digit cell) ; advance
(solve (cdr empty) (cons (new cell digit) filled)))
(else (try cell (next digit))))) ; try next digit
(let ((str (make-string 81 #\0)))
(do ((filled filled (cdr filled))) ((null? filled) str)
(let* ((cell (car filled)) (s (+ (* (vector-ref cell 0) 9) (vector-ref cell 1))))
(string-set! str s (vector-ref cell 3))))))))))
The sample puzzle is solved as follows:
> (sudoku "700100000020000015000006390200018000040090070000750003078500000560000040000001002")
"789135624623947815451286397237418569845693271916752483178524936562379148394861752"
This code is available as http://programmingpraxis.codepad.org/PB1czuyF.
Mathematically, Sudoku is an instance of the exact cover problem, and is best solved using an algorithm called dancing links due to Donald Knuth, which is very much faster than the backtracking method shown above; the dancing links method will solve Sudoku puzzles at the rate of several hundred per second on a typical personal computer.
Programming Praxis 
Some time back I had read Peter Norvig’s beautiful post Solving Every Sudoku Puzzle, and tried to convert his program into Haskell. His idea, in short, was to use constraint propagation to fill up as many values as possible; and then ultimately search.
Though the resulting Haskell program was not as succinct as his original Python, I thought it wasn’t too bad either. Perhaps using some monad trick (that I yet have to learn!) all the checks against ‘Nothing’ can be eliminated.
One (only?) answer, got in under a second, is:
7 8 9 |1 3 5 |6 2 4
6 2 3 |9 4 7 |8 1 5
4 5 1 |2 8 6 |3 9 7
------+------+------
2 3 7 |4 1 8 |5 6 9
8 4 5 |6 9 3 |2 7 1
9 1 6 |7 5 2 |4 8 3
------+------+------
1 7 8 |5 2 4 |9 3 6
5 6 2 |3 7 9 |1 4 8
3 9 4 |8 6 1 |7 5 2
And my Haskell translation is (gist):
import List (elem, nub, filter, delete, intersperse, replicate)
import Data.Map (Map, fromList, (!), insert, keys, elems, toList)
import Data.List (intercalate)
import Data.Maybe
type Val = Char -- Value of a cell
type Square = String -- two-character square ID
type Board = Maybe (Map Square String) -- The board state
cross xs ys = [[x,y] | x <- xs, y <- ys]
rows = "ABCDEFGHI"
cols = "123456789"
digits = "123456789"
squares = cross rows cols
unitlist = [cross rows [c] | c <- cols]
++ [cross [r] cols | r <- rows]
++ [cross rs cs | rs <- ["ABC", "DEF", "GHI"], cs <- ["123","456","789"]]
units sq = filter (elem sq) unitlist
peers sq = delete sq . nub . concat $ units sq
-- Check for places where d appears in the units of sq
checkplaces :: Board -> Square -> Val -> Board
checkplaces b0 sq d = foldl f b0 (units sq)
where f b u
| isNothing b || len == 0 = Nothing
| len == 1 = assign b (head dplaces) d
| otherwise = b
where dplaces = [s | s <- u, elem d ((fromJust b)!s)]
-- dplaces is all squares in the unit u possibly containing d
len = length dplaces
eliminate :: Board -> Square -> Val -> Board
eliminate Nothing _ _ = Nothing
eliminate (Just b0) sq d
| notElem d v = Just b0 -- Already Eliminated
| length v' == 0 = Nothing -- Contradiction: Removed last value
| length v' == 1 = checkplaces b'' sq d -- Only 1 left: Remove from peers
| otherwise = checkplaces (Just b') sq d
where v = b0 ! sq
v' = delete d v
b' = insert sq v' b0
h = (head v')
b'' = foldl (\b p -> eliminate b p h) (Just b') (peers sq)
assign :: Board -> Square -> Val -> Board
assign Nothing _ _ = Nothing
assign b0 sq d0 = foldl f b0 ((fromJust b0) ! sq)
where f b d = if d0 == d then b else eliminate b sq d
parsegr :: String -> Board
parsegr s = foldl f b0 (zip squares s')
where s' = filter (\x -> elem x "0.-123456789") s
b0 = Just (fromList [(s, digits) | s <- squares])
f b (sq, d)
| isNothing b = Nothing
| notElem d digits = b
| otherwise = assign b sq d
search :: Board -> Board
search Nothing = Nothing
search (Just b) =
if all ((==1) . length) $ elems b then Just b else search' (b!s)
where minl = minimum [l | v <- elems b, let l = length v, l > 1]
s = head [sq | (sq, v) <- toList b, length v == minl]
search' [] = Nothing
search' (d:ds) = if isJust b' then b' else search' ds
where b' = search $ assign (Just b) s d
printgr :: Board -> String
printgr Nothing = "Unsolvable"
printgr (Just b) = concat [(fr r) ++ (if elem r "CF" then line else "") ++ "\n" | r<-rows]
where w = 1 + maximum [length (b!sq) | sq <- squares]
line = (++) "\n" $ intercalate "+" $ replicate 3 $ replicate (3 * w) '-'
fr r = concat [(fmt (b![r,c])) ++ (if elem c "36" then "|" else "") | c<-cols]
fmt s = s ++ replicate (w - (length s)) ' '
solve :: String -> IO ()
solve s = putStrLn $ printgr $ search $ parsegr s
-- Instance from http://programmingpraxis.com/2009/02/19/sudoku/2/
grid = "7..1......2.....15.....639.2...18....4..9..7....75...3.785.....56.....4......1..2"
main = solve grid
Here’s my implementation, based on the Dlx algorithm:
http://codepad.org/a1lsh3ga
Implementation of DLX in PLT Scheme. This solves the sample problem in about 20ms on my machine.
http://github.com/d3zd3z/praxis/blob/master/2009/02-19-sudoku.ss
#lang racket ; By Jos Koot. #| Procedure: (sudoku p) -> (s ...) or "erroneous puzzle" p : puzzle : 9x9 matrix of digits. s : solution : like p but not containing zeros. digit : one of the exact integer numbers from 0 up to and including 9. nxm matrix : vector of n vectors of m elements each. Purpose: To solve sudoku puzzle represented by p. In p 0 represents an unoccupied field. The procedure first displays the puzzle and the number of solutions, then returns the list of all solutions. |# (define (sudoku p) ; (get x y) -> element (x,y) of matrix p. (define (get x y) (vector-ref (vector-ref p x) y)) ; (put! x y n) -> stores n in element (x,y) of matrix p. (define (put! x y n) (vector-set! (vector-ref p x) y n)) ; (copy) -> copy of p (define (copy) (let copy ((p p)) (if (vector? p) (apply vector (map copy (vector->list p))) p))) ; hash : hash-table with fields (x y) for keys and providing a list of all ; other fields (x' y') that must not contain the same digit as field (x y). (define hash (let ((hash (make-hash))) (for* ((x (in-range 0 9)) (y (in-range 0 9))) (hash-set! hash (list x y) (remove (list x y) (remove-duplicates (append (for*/list ((z (in-range 0 9))) (list x z)) (for*/list ((z (in-range 0 9))) (list z y)) (let ((x (* 3 (quotient x 3))) (y (* 3 (quotient y 3)))) (for*/list ((x (in-range x (+ x 3))) (y (in-range y (+ y 3)))) (list x y)))))))) hash)) ; (occ x y) -> list of non zero digits ; To be used for unoccupied fields. ; Returns the list of digits field (x y) must not contain. (define (occ x y) (remove-duplicates (filter positive? (map (λ (xy) (apply get xy)) (hash-ref hash (list x y)))))) ; (free x y) -> list of non zero digits ; To be used for unoccupied fields. ; Returns the list of digits field (x y) stiull feasible during the search. (define (free x y) (remove* (occ x y) '(1 2 3 4 5 6 7 8 9))) ; n-occ : number of occupied (non zero) elements in the original puzzle. (define n-occ (let ((n-occ 0)) (for* ((x (in-range 0 9)) (y (in-range 0 9))) (when (positive? (get x y)) (set! n-occ (add1 n-occ)))) n-occ)) ; (solve x y n-occ sols) -> (s ...) ; Does a depth first search on all free fields and all allowed digits. (define (solve x y n-occ sols) ; try loops allong the free digits allowed in free field (x y). (define (try frees sols) (if (null? frees) (begin (put! x y 0) sols) (begin (put! x y (car frees)) (let ((sols (solve x (add1 y) (add1 n-occ) sols))) (try (cdr frees) sols))))) (cond ((= n-occ 81) (cons (copy) sols)) ((= x 9) sols) ((= y 9) (solve (add1 x) 0 n-occ sols)) ((positive? (get x y)) (solve x (add1 y) n-occ sols)) (else (try (free x y) sols)))) ; (test) checks that the puzzle is correct. (define (test) (and (vector? p) (= (vector-length p) 9) (for*/and ((x (in-range 0 9))) (let ((row (vector-ref p x))) (and (vector? row) (= (vector-length row) 9) (andmap digit? (vector->list row))))) (for*/and ((x (in-range 0 9))(y (in-range 0 9))) (let ((n (get x y))) (or (zero? n) (not (member n (occ x y)))))))) (define (digit? x) (and (number? x) (exact? x) (integer? x) (<= 0 x 9))) (printf "~nPuzzle:~n~n") (pretty-display p) (newline) (if (test) (begin (let ((sols (solve 0 0 n-occ '()))) (printf "has ~s solutions:~n~n" (length sols)) sols)) (printf "is inconsistent.~n~n"))) (sudoku ; 1 sol #(#(7 0 0 1 0 0 0 0 0) #(0 2 0 0 0 0 0 1 5) #(0 0 0 0 0 6 3 9 0) #(2 0 0 0 1 8 0 0 0) #(0 4 0 0 9 0 0 7 0) #(0 0 0 7 5 0 0 0 3) #(0 7 8 5 0 0 0 0 0) #(5 6 0 0 0 0 0 4 0) #(0 0 0 0 0 1 0 0 2))) (sudoku ; no solutions #(#(7 0 0 1 0 0 0 0 0) #(0 2 0 0 0 0 0 1 5) #(0 0 0 0 0 6 3 9 0) #(2 0 0 0 1 8 0 0 0) #(0 4 0 0 9 0 0 7 0) #(0 0 0 7 5 0 0 0 3) #(0 7 8 5 0 0 0 0 0) #(5 6 0 0 0 0 0 4 0) #(0 0 3 0 0 1 0 0 2))) (sudoku ; 50 solutions #(#(7 0 0 1 0 0 0 0 0) #(0 2 0 0 0 0 0 1 5) #(0 0 0 0 0 6 3 9 0) #(2 0 0 0 1 8 0 0 0) #(0 4 0 0 9 0 0 7 0) #(0 0 0 7 5 0 0 0 3) #(0 7 8 5 0 0 0 0 0) #(5 6 0 0 0 0 0 4 0) #(0 0 0 0 0 1 0 0 0))) (sudoku ; 12 solutions #(#(7 8 9 1 3 5 6 2 4) #(0 2 0 0 0 0 0 1 5) #(0 0 0 0 0 6 3 9 0) #(2 0 0 0 1 8 0 0 0) #(0 4 0 0 9 0 0 7 0) #(0 0 0 7 5 0 0 0 3) #(0 7 8 5 0 0 0 0 0) #(5 6 0 0 0 0 0 4 0) #(0 0 0 0 0 1 0 0 0))) (sudoku ; erroneous puzzle #(#(7 8 9 1 1 0 0 0 0) #(0 2 0 0 0 0 0 1 5) #(0 0 0 0 0 6 3 9 0) #(2 0 0 0 1 8 0 0 0) #(0 4 0 0 9 0 0 7 0) #(0 0 0 7 5 0 0 0 3) #(0 7 8 5 0 0 0 0 0) #(5 6 0 0 0 0 0 4 0) #(0 0 0 0 0 1 0 0 2))) (sudoku ; 14 solutions #(#(1 2 3 4 5 6 7 8 9) #(4 5 6 7 8 9 1 2 3) #(7 8 9 1 2 3 4 5 6) #(2 3 1 0 0 0 0 0 0) #(5 6 4 0 3 0 0 0 0) #(8 9 7 0 0 5 0 0 0) #(3 1 2 0 0 0 9 0 0) #(6 4 5 0 0 0 0 7 0) #(9 7 8 0 0 0 0 0 1))) (sudoku #(#(7 0 0 0 0 0 0 1 9) #(4 6 0 1 9 0 0 0 0) #(0 0 0 6 8 2 7 0 4) #(0 9 0 0 0 0 0 0 7) #(0 0 0 3 0 0 4 0 5) #(0 0 6 7 0 0 0 0 0) #(0 0 1 0 0 0 0 0 0) #(2 0 0 0 7 4 0 0 0) #(0 0 0 2 0 0 3 0 0)))Solving sudoku is interseting.
How about designing sudoku puzzles that have exactly one solution?
Does anyone have an idea how to do that?
I can think of the following:
0: Initially all fields are unoccupied.
1: Randomly choose an unoccupied field.
2: Take all consistent digits in arbitrary order.
3: If there are no consistent digits backtrack from step 1.
4: Try the digits in arbitrary order.
5: For each trial solve the puzzle to a maximum of two solutions.
6: If there is no solution, try the next consistent digit or backtrack from step 1 if no digits are left.
7: If there is one solution we are ready.
9: If there is more than one solution, try to complete the puzzle from step 1.
Jos
https://github.com/gcapell/ProgrammingPraxis/blob/master/04_sudoku/sudoku.go
This is a solution in php that uses backtracking.
You start with a first empty cell and the least number that fits there (i.e. with no conflict from other numbers that are already supplied in the puzzle).
And apply the same logic to the next empty cell, till you’re not able to fill any number in an empty cell – at which time you backtrack to the previous cell, change the number there and try again.
So for the above Sudoku puzzle, since the first empty cell is in (1,2), the function below will first be invoked as:
solve(1,1,2)
$game_table is just an array of 9X9 that already contains supplied numbers in the puzzle
$complete will be set to FALSE before calling solve() for the first time
function solve($number,$row,$column)
{
global $game_table;
global $complete;
while($number<=9 && !$complete)
{
//check is this number can fit into this cell
if(check_horizontal($number,$row,$column) && check_vertical($number,$row,$column) && check_square($number,$row,$column))
{
$game_table[$row][$column]=$number; //no conflict, so fill the cell with this number
//find the next blank cell
$i=1;$j=1;$found=false;
for($i=1;$i<=9;$i++)
{
for($j=1;$j<=9;$j++)
{
if($game_table[$i][$j]==0)
{
$found=true;
break;
}
}
if ($found) break;
}
if($found)
solve(1,$i,$j); //recursive call
else
{
$complete= true;
return;
}
}
//recursive call will return here – so here either the puzzle is complete or there was no possibility to fill the next cell
if(!$complete)
$number++;
}
if(!$complete)
$game_table[$row][$column]=0; //reset this cell
}
function check_horizontal($n,$r,$c)
{
global $game_table;
for($j=1;$j<=9;$j++)
if($game_table[$r][$j]==$n) return false;
return true;
}
function check_vertical($n,$r,$c)
{
global $game_table;
for($i=1;$i<=9;$i++)
if($game_table[$i][$c]==$n) return false;
return true;
}
function check_square($n,$r,$c)
{
global $game_table;
$a = $r%3;
$b = floor($r/3);
if($a==0)
{
$r1 = (3*($b-1))+1;
$r2 = $r;
}
else
{
$r1 = $r-$a+1;
$r2 = 3*($b+1);
}
$a = $c%3;
$b = floor($c/3);
if($a==0)
{
$c1 = (3*($b-1))+1;
$c2 = $c;
}
else
{
$c1 = $c-$a+1;
$c2 = 3*($b+1);
}
for($i=$r1;$i<=$r2;$i++)
for($j=$c1;$j<=$c2;$j++)
if($game_table[$i][$j] == $n) return false;
return true;
}
golang
package main import "fmt" const PROBLEM = "7..1......2.....15.....639.2...18....4..9..7....75...3.785.....56.....4......1..2" func solve(p []uint8, i int) { for i < 81 && p[i] != '.' { i++ } if i > 80 { fmt.Println("---------") for i := 0; i < 9; i++ { fmt.Println(string(p[i * 9: (i + 1) * 9])) } } else { w, v := make([] bool, 58), i % 9 h, b := i - v, ((i / 9) / 3) * 27 + (v / 3) * 3 for n := 0; n < 9; n++ { w[p[v]] = true; w[p[h]] = true; w[p[b]] = true v += 9; h += 1; if n % 3 == 2 { b += 7 } else { b += 1 } } for j := 49; j < 58; j++ { if !w[j] { p[i] = uint8(j); solve(p, i + 1); p[i] = '.' } } } } func main() { solve([]uint8(PROBLEM), 0) }Python: https://github.com/ftt/programming-praxis/blob/master/20090219-sudoku/sudoku.py
This is roughly based on an article by P. Norvig I read once (Ashutosh Mehra mentions that article), but I’ve tried to implement it from memory, so the result is not as clean as the original.