Skip to content

Instantly share code, notes, and snippets.

@astro

astro/sudoku-solver.hs

Created July 7, 2009 15:40
Show Gist options
  • Save astro/142162 to your computer and use it in GitHub Desktop.
Save astro/142162 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
sudoku-solver.hs
-- I didn't read
-- http://www.cs.tufts.edu/~nr/comp150fp/archive/richard-bird/sudoku.pdf
-- too carefully.
import Array
import Control.Monad (forM_)
import Data.List (delete, intercalate)
import System.CPUTime (getCPUTime)
import Control.Parallel.Strategies
type Cell = Maybe Int
data Board = Board Int -- ^Size
(Array (Int, Int) Cell) -- ^Cells
instance NFData Board where
rnf (Board size cells) = size `seq` seqArr rnf cells
digits :: Board -> [Int]
digits (Board size _) = [1..size]
collectNumbers :: Board -> [Int] -> [Int] -> [Int]
collectNumbers (Board _ cells) xs ys = filter (/= 0) $
map (maybe 0 id) $
[cells ! (x, y)
| x <- xs, y <- ys]
possibleDigits :: Board -> Int -> Int -> [Int]
possibleDigits board@(Board size _) x y =
let size' = size - 1
colNumbers = collectNumbers board [x] [0..size']
rowNumbers = collectNumbers board [0..size'] [y]
-- sqrt sucks cpu!
boxSize = truncate $ sqrt $ fromIntegral size
bx = (x `div` boxSize) * boxSize
by = (y `div` boxSize) * boxSize
boxNumbers = collectNumbers board [bx..(bx + boxSize - 1)] [by..(by + boxSize - 1)]
takenNumbers = colNumbers ++ rowNumbers ++ boxNumbers
in foldl (flip delete) (digits board) takenNumbers
solutions' board@(Board size cells) x y depth
| x >= size = solutions' board 0 (y + 1) depth
| y >= size = [board]
| otherwise = case cells ! (x, y) of
Just _ -> solutions' board x' y depth
Nothing -> concat $
parallel $
map (\digit ->
let board' = Board size (cells // [((x, y), Just digit)])
in solutions' board' x' y depth'
) $
possibleDigits board x y
where x' = x + 1
depth' = depth + 1
parallel | depth < 6 = (`using` parList rnf)
| otherwise = id
solutions :: Board -> [Board]
solutions board = solutions' board 0 0 0
problem1 = [[2, 0, 0, 0, 0, 1, 0, 3, 8],
[0, 0, 0, 0, 0, 0, 0, 0, 5],
[0, 7, 0, 0, 0, 6, 0, 0, 0],
[0, 0, 0, 0, 0, 0, 0, 1, 3],
[0, 9, 8, 1, 0, 0, 2, 5, 7],
[3, 1, 0, 0, 0, 0, 8, 0, 0],
[9, 0, 0, 8, 0, 0, 0, 2, 0],
[0, 5, 0, 0, 6, 9, 7, 8, 4],
[4, 0, 0, 2, 5, 0, 0, 0, 0]]
problem2 = [[1, 0, 0, 8, 0, 0, 0, 3, 0],
[7, 0, 0, 0, 0, 0, 0, 2, 0],
[0, 0, 0, 5, 6, 0, 0, 7, 0],
[0, 0, 8, 0, 0, 0, 9, 0, 0],
[0, 0, 5, 2, 1, 7, 4, 0, 0],
[0, 0, 4, 0, 0, 0, 7, 0, 0],
[0, 3, 0, 0, 8, 9, 0, 0, 0],
[0, 2, 0, 0, 0, 0, 0, 0, 8],
[0, 8, 0, 0, 0, 4, 0, 0, 6]]
problem3 = [[0, 0, 0, 0],
[1, 3, 4, 0],
[4, 0, 0, 1],
[3, 0, 0, 0]]
problem4 = [[4, 13, 0, 0, 8, 6, 2, 7, 5, 0, 0, 0, 3, 10, 9, 14],
[0, 0, 6, 5, 0, 9, 14, 0, 0, 4, 3, 0, 0, 13, 2, 0],
[0, 14, 12, 9, 0, 5, 0, 0, 0, 0, 0, 0, 4, 0, 0, 7],
[0, 3, 0, 0, 0, 10, 0, 16, 7, 11, 0, 0, 0, 0, 1, 0],
[0, 2, 3, 4, 1, 12, 0, 0, 0, 0, 0, 15, 0, 16, 8, 0],
[0, 8, 0, 1, 14, 0, 16, 2, 0, 0, 0, 0, 11, 0, 0, 0],
[0, 11, 5, 0, 13, 3, 9, 0, 0, 16, 0, 4, 0, 0, 0, 2],
[0, 16, 0, 7, 15, 0, 0, 0, 3, 0, 13, 2, 0, 9, 10, 0],
[0, 0, 0, 16, 0, 0, 0, 11, 0, 1, 6, 13, 9, 0, 0, 4],
[11, 0, 0, 8, 5, 0, 3, 9, 2, 14, 12, 16, 10, 0, 13, 15],
[0, 0, 0, 13, 16, 4, 0, 14, 10, 0, 8, 7, 0, 0, 0, 0],
[0, 15, 10, 0, 0, 0, 0, 0, 4, 9, 0, 0, 8, 7, 16, 1],
[0, 0, 11, 0, 7, 0, 4, 1, 0, 10, 0, 14, 16, 0, 0, 0],
[2, 12, 16, 0, 0, 0, 8, 3, 0, 0, 0, 0, 13, 0, 14, 0],
[3, 4, 7, 14, 0, 0, 10, 5, 0, 2, 11, 0, 12, 0, 0, 6],
[5, 0, 8, 0, 12, 14, 11, 0, 16, 6, 9, 3, 2, 4, 0, 0]]
problem5 = [[0, 0, 0, 0, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0],
[0, 0, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 13, 2, 0],
[0, 14, 0, 9, 0, 5, 0, 0, 0, 0, 0, 0, 4, 0, 0, 7],
[0, 3, 0, 0, 0, 0, 0, 0, 7, 11, 0, 0, 0, 0, 1, 0],
[0, 0, 3, 4, 0, 0, 0, 0, 0, 0, 0, 15, 0, 0, 8, 0],
[0, 8, 0, 0, 14, 0, 0, 2, 0, 0, 0, 0, 11, 0, 0, 0],
[0, 0, 5, 0, 13, 0, 9, 0, 0, 0, 0, 4, 0, 0, 0, 2],
[0, 0, 0, 7, 15, 0, 0, 0, 3, 0, 0, 2, 0, 0, 10, 0],
[0, 0, 0, 0, 0, 0, 0, 11, 0, 1, 0, 0, 9, 0, 0, 4],
[11, 0, 0, 8, 5, 0, 3, 0, 0, 0, 12, 0, 10, 0, 13, 15],
[0, 0, 0, 13, 0, 4, 0, 14, 10, 0, 8, 7, 0, 0, 0, 0],
[0, 15, 10, 0, 0, 0, 0, 0, 4, 9, 0, 0, 8, 7, 0, 1],
[0, 0, 11, 0, 7, 0, 4, 1, 0, 10, 0, 14, 0, 0, 0, 0],
[2, 12, 0, 0, 0, 0, 8, 3, 0, 0, 0, 0, 13, 0, 14, 0],
[3, 4, 7, 14, 0, 0, 10, 5, 0, 2, 11, 0, 12, 0, 0, 6],
[5, 0, 8, 0, 12, 14, 11, 0, 0, 6, 9, 3, 2, 4, 0, 0]]
listToBoard :: [[Int]] -> Board
listToBoard cellsA =
let cells = array ((0, 0), (size', size')) [((x, y), case cellsA !! y !! x of
0 -> Nothing
digit -> Just digit)
| y <- [0..size'], x <- [0..size']]
size = length cellsA
size' = size - 1
in Board size cells
solve :: [[Int]] -> IO ()
solve problem = let board = listToBoard problem
in do
putStrLn "+++"
putStrLn $ showBoard board
putStrLn ""
t1 <- getCPUTime
forM_ (solutions $ listToBoard problem) $ \solution ->
do putStrLn $ showBoard solution
putStrLn ""
t2 <- getCPUTime
putStrLn $ (show $ (t2 - t1) `div` 1000000) ++ " µs elapsed"
showBoard :: Board -> String
showBoard (Board size cells) =
intercalate "\n" $
map (\y ->
intercalate " " $
map (\x ->
let cell = cells ! (x, y)
in pad 2 $ maybe " " show cell
) [0..(size - 1)]
) [0..(size - 1)]
main = forM_ [problem1, problem2, problem3, problem4, problem5] solve
pad len s | length s < len = pad len $ ' ':s
| otherwise = s
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment