# Speeding up naive backtracking Sudoku Solver in Haskell

Posted on

Problem

After watching a recent computerphile video on building a very simple sudoku solver I tried to implement the same in Haskell. From this CR question I learned that it is probably a better idea to use Vectors instead of just lists to represent a grid of numbers that is gonna be mutated. (But it is supposedly still worse than using a sparse representation.) And from this one (and another question of mine) I learned about `Control.Lens`, but I decided against using it to avoid using many different packages that I’m not familiar with.

Now the program I wrote is close to the original in python, but very slow. So I would like to get some feedback on how to speed it up without deviating form this very simple aproach too much.

### The Program

The code defines a `Board` that represents a (solved or unsolved) state, with zeros for the entries that area yet to be determined. It can be indexed using `Coordinates`. Then there are a few setters and getters that probably could be replaced by using `Control.Lens` – but I’d like to avoid that for now as I just want to focus on the performance. Then there is a `possible` function which takes a `Board`, `Coordinates` and a candidate number an just reports whether it is possible to put the candidate at some given coordinates. Finally there is `solve` that does the backtracking.

So far I tried to add a `take 1 \$` or `take 1 \$!` to speed it up (but only returning at most a single solution), but without success.

``````--https://www.youtube.com/watch?v=G_UYXzGuqvM
import qualified Data.Vector as V

data Board = Board (V.Vector (V.Vector Integer))
type Coordinates = (Int, Int)

instance Show Board where
show (Board b)=unlines . V.toList \$ V.map show b

fromList :: [[Integer]] -> Board
fromList l = Board \$ V.fromList \$ V.fromList <\$> l

-- a few setters and getters
(!):: Board -> Coordinates -> Integer
(Board b) ! (i,j) = (b  V.! j)V.! i

getColumn :: Board -> Coordinates -> [Integer]
getColumn b (i, _) = [b ! (i, j) | j<-[0..8]]

getRow :: Board -> (Int, Int) -> [Integer]
getRow b (_, j) = [b ! (i, j) | i<-[0..8]]

getSquare :: Board -> Coordinates -> [Integer]
getSquare b (i, j) = [b ! (i'*3 + u, j'*3 + v) | u<-[0..2],v<-[0..2]]
where i' = i `div` 3
j' = j `div` 3

insert :: Board -> Coordinates -> Integer -> Board
insert (Board b) (i, j) k = Board b'
where v = b V.! j
v' = v V.// [(i, k)]
b' = b V.// [(j, v')]

-- check whether it is possible to insert candidate at given position
possible :: Board -> Coordinates -> Integer -> Bool
possible b coords@(i, j) k
|i < 0 || i >= 9 || j < 0 || j >= 9 || k < 0 || k > 9 = undefined
|b ! coords > 0 = False
|k `elem` getRow b coords = False
|k `elem` getColumn b coords = False
|k `elem` getSquare b coords = False
|otherwise = True

-- check whether board is already full
full :: Board -> Bool
full b = 0 `notElem` [b ! (i,j) | i<-[0..8], j<-[0..8]]

-- recursion to find all solutions to a given board
solve :: Board -> [Board]
solve b
|full b = [b]
|otherwise =  concat[ solve \$! (insert b (x, y) n)|
x<-[0..8],
y<-[0..8],
n<-[1..9],
possible b (x,y) n]

main = print \$ solve b

-- normal sudoku
b :: Board
b = fromList [
[5,3,0,0,7,0,0,0,0],
[6,0,0,1,9,5,0,0,0],
[0,9,8,0,0,0,0,6,0],
[8,0,0,0,6,0,0,0,3],
[4,0,0,8,0,3,0,0,1],
[7,0,0,0,2,0,0,0,6],
[0,6,0,0,0,0,2,8,0],
[0,0,0,4,1,9,0,0,5],
[0,0,0,0,8,0,0,7,9]
]

-- only one a few entries are missing
c :: Board
c = fromList [
[0,0,0,0,9,4,5,6,1],
[9,2,1,5,3,6,8,7,4],
[4,5,6,7,8,1,9,2,3],
[1,4,7,3,5,9,2,8,6],
[2,8,3,6,1,7,4,5,9],
[5,6,9,8,4,2,3,1,7],
[6,7,4,9,2,5,1,3,8],
[8,9,2,1,7,3,6,4,5],
[3,1,5,4,6,8,7,9,2]]

``````

Try it online!

Solution

It turns out I made some crucial mistakes: The iteration in `solve` can stop as soon we have tried all possibilities for one coordinate `(x,y)` that is not set yet. If we iterate further over `(x,y)` we get duplicate solutions which makes things blow up, so with following little modification we get results immediately:

``````isEmpty :: Board -> Coordinates -> Bool
isEmpty b coords = b ! coords == 0

-- check whether board is already full
full :: Board -> Bool
full b = 0 `notElem` [b ! (i,j) | i<-[0..8], j<-[0..8]]

-- recursion to find all solutions to a given board
solve :: Board -> [Board]
solve b
|full b = [b]
|otherwise =  concat[ solve \$! (insert b (x, y) n)|
(x,y) <- take 1 empty,
n <- [1..9],
possible b (x,y) n]
where empty = [(x,y) | x<-[0..8],y<-[0..8], isEmpty b (x, y)]
``````

Try it online!