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]]
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)]