1
\$\begingroup\$

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!

\$\endgroup\$
8
  • \$\begingroup\$ Since I don't have a Haskell environment at hand, just a short question instead of a full-answer: did you profile your program? \$\endgroup\$
    – Zeta
    Mar 8, 2020 at 10:31
  • 1
    \$\begingroup\$ @Zeta No I haven't, thanks for the suggestion. Can you recommend a place to start out with profiling? I have never profiled Haskell programs. \$\endgroup\$
    – flawr
    Mar 8, 2020 at 10:49
  • \$\begingroup\$ That's from the top of my head, but try -prof -fprof-auto -O<optimization-level> via GHC. If you use stack, there should be --profile for stack's build command. Afterwards, you have to tell the runtime to write a profile. On your application, use +RTS -p. That's the quick gist. I believe some of my old answers here on CR contain examples on profiling. \$\endgroup\$
    – Zeta
    Mar 8, 2020 at 11:18
  • \$\begingroup\$ Keep in mind that you need to compile all your dependencies (e.g. vector and probably primitive) also with profiling enabled, which can take a while. \$\endgroup\$
    – Zeta
    Mar 8, 2020 at 11:22
  • 1
    \$\begingroup\$ "Now the program I wrote is close to the original in python, but very slow. " I'm currently running your program on a Windows 10 machine with profiling enabled, and thus far it took more than 7 minutes without any result. How slow is "very slow" on your site? \$\endgroup\$
    – Zeta
    Mar 8, 2020 at 11:31

1 Answer 1

2
\$\begingroup\$

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!

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.