[Haskell-cafe] Norvig's Sudoku Solver in Haskell
manu
emmanuel.delaborde at citycampus.com
Sun Aug 26 08:50:00 EDT 2007
Hello,
After reading Peter Norvig's take on writing a Sudoku solver (http://
norvig.com/sudoku.html)
I decided that I would port his program to Haskell, without changing
the algorithm, that'll make a nice exercise I thought
and should be fairly easy... Boy, was I wrong !
Anyway, I eventually managed to tiptoe around for loops, mutable
state, etc...
However, when I run my program against the test data provided (http://
norvig.com/top95.txt),
I find it takes around 1m20 s to complete (compiled with -fvia-C and -
O2, on a MacBook Pro 2.33GHz Intel Core 2 Duo).
That's roughly 8 times longer than Norvig's Python script. That's not
what I expected !
My program is also longer than the Python version.
Being a beginner, I am convinced my implementation is super naive and
non idiomatic. A seasonned Haskeller would do much shorter and much
faster. I don't know how to improve it though !
Should I introduce more strictness ? replace lists with more
efficient data structures (ByteStrings, Arrays) ?
Here is my program, and part of the profiling (memory allocation
looks huge !)
I hope this post wasn't too long. Thanks for any advice !
Emmanuel.
{-
This is an attempt to implement in Haskell, Peter Norvig's sudoku
solver :
"Solving Every Sudoku Puzzle" (http://norvig.com/sudoku.html)
In Norvig's program, methods which change a grid return either a new
grid, either False (failure).
Here I use Maybe, and return Just grid or Nothing in case of failure
-}
module Main where
import Prelude hiding (lookup)
import Data.List hiding (lookup)
import qualified Data.Map as M
import Control.Monad
import Maybe
import System.IO
--------------------------------------------------
-- Types
type Digit = Char
type Square = String
type Unit = [Square]
-- We represent our grid as a Map
type Grid = M.Map Square [Digit]
--------------------------------------------------
-- Setting Up the Problem
rows = "ABCDEFGHI"
cols = "123456789"
digits = "123456789"
cross :: String -> String -> [String]
cross rows cols = [ r:c:[] | r <- rows, c <- cols ]
squares :: [Square]
squares = cross rows cols -- ["A1","A2","A3",...]
unitlist :: [Unit]
unitlist = [ cross rows [c] | c <- cols ] ++
[ cross [r] cols | r <- rows ] ++
[ cross rs cs | rs <- ["ABC","DEF","GHI"], cs <-
["123","456","789"]]
units :: M.Map Square [Unit]
units = M.fromList [ (s, [ u | u <- unitlist, elem s u ]) | s <-
squares ]
peers :: M.Map Square [Square]
peers = M.fromList [ (s, set [[ p | p <- e, p /= s ] | e <- lookup s
units ]) | s <- squares ]
where set = nub . concat
--------------------------------------------------
-- Wrapper around M.lookup used in list comprehensions
lookup :: (Ord a, Show a) => a -> M.Map a b -> b
lookup k v = case M.lookup k v of
Just x -> x
Nothing -> error $ "Error : key " ++ show k ++ " not
in map !"
-- lookup k m = fromJust . M.lookup k m
--------------------------------------------------
-- Parsing a grid into a Map
parsegrid :: String -> Maybe Grid
parsegrid g = do regularGrid g
foldM assign allPossibilities (zip squares g)
where allPossibilities :: Grid
allPossibilities = M.fromList [ (s,digits) | s <- squares ]
regularGrid :: String -> Maybe String
regularGrid g = if all (\c -> (elem c "0.-123456789")) g
then (Just g)
else Nothing
--------------------------------------------------
-- Propagating Constraints
assign :: Grid -> (Square, Digit) -> Maybe Grid
assign g (s,d) = if (elem d digits) then do -- check that we are
assigning a digit and not a '.'
let toDump = delete d (lookup s g)
res <- foldM eliminate g (zip (repeat s) toDump)
return res
else return g
eliminate :: Grid -> (Square, Digit) -> Maybe Grid
eliminate g (s,d) = let cell = lookup s g in
if not (elem d cell) then return g -- already
eliminated
-- else d is deleted from s' values
else do let newCell = delete d cell
newV = M.insert s newCell g --
newV2 <- case length newCell of
-- contradiction :
Nothing terminates the computation
0 -> Nothing
-- if there is only one
value (d2) left in square, remove it from peers
1 -> do let peersOfS =
[ s' | s' <- lookup s peers ]
res <- foldM
eliminate newV (zip peersOfS (cycle newCell))
return res
-- else : return the new
grid
_ -> return newV
-- Now check the places where d
appears in the units of s
let dPlaces = [ s' | u <- lookup s
units, s' <- u, elem d (lookup s' newV2) ]
case length dPlaces of
0 -> Nothing
-- d can only be in one place in
unit; assign it there
1 -> assign newV2 (head dPlaces, d)
_ -> return newV2
--------------------------------------------------
-- Search
search :: Maybe Grid -> Maybe Grid
search Nothing = Nothing
search (Just g) = if all (\xs -> length xs == 1) [ lookup s g | s <-
squares ]
then (Just g) -- solved
else do let (_,s) = minimum [ (length (lookup s
g),s) | s <- squares, length (lookup s g) > 1 ]
g' = g -- copie of g
foldl' some Nothing [ search (assign
g' (s,d)) | d <- lookup s g ]
where some Nothing Nothing = Nothing
some Nothing (Just g) = (Just g)
some (Just g) _ = (Just g)
--------------------------------------------------
-- Display solved grid
printGrid :: Grid -> IO ()
printGrid = putStrLn . gridToString
gridToString :: Grid -> String
gridToString g = let l0= map snd (M.toList g) --
[("1537"),("4"),...]
l1 = (map (\s -> " " ++ s ++ " ")) l0 -- ["
1 "," 2 ",...]
l2 = (map concat . sublist 3) l1 -- ["
1 2 3 "," 4 5 6 ",...]
l3 = (sublist 3) l2 -- [["
1 2 3 "," 4 5 6 "," 7 8 9 "],...]
l4 = (map (concat . intersperse "|")) l3 -- ["
1 2 3 | 4 5 6 | 7 8 9 ",...]
l5 = (concat . intersperse [line] . sublist 3) l4
in unlines l5
where sublist n [] = []
sublist n xs = take n xs : sublist n (drop n xs)
line = hyphens ++ "+" ++ hyphens ++ "+" ++ hyphens
hyphens = take 9 (repeat '-')
--------------------------------------------------
main :: IO ()
main = do h <- openFile "top95.txt" ReadMode
grids <- hGetContents h
let solved = mapMaybe (search . parsegrid) (lines grids)
mapM_ printGrid solved
hClose h
************************************************************************
***
Sun Aug 26 13:44 2007 Time and Allocation Profiling Report (Final)
sudoku_norvig +RTS -p -hc -RTS
total time = 49.40 secs (988 ticks @ 50 ms)
total alloc = 6,935,777,308 bytes (excludes profiling overheads)
COST CENTRE MODULE %time %alloc
lookup Main 65.7 22.6
eliminate Main 32.4 70.3
search Main 1.8 6.3
individual inherited
COST CENTRE
MODULE no. entries %
time %alloc %time %alloc
MAIN
MAIN 1
0 0.0 0.0 100.0 100.0
main
Main 190
1 0.0 0.0 100.0 100.0
printGrid
Main 214
95 0.0 0.0 0.0 0.1
gridToString
Main 215
665 0.0 0.1 0.0 0.1
search
Main 208
427143 1.8 6.3 99.4 99.2
assign
Main 210
468866 0.1 0.6 90.4 90.3
eliminate
Main 212 30626903
32.2 69.8 89.9 89.6
lookup
Main 213 172203504
57.7 19.9 57.7 19.9
lookup
Main 211
468866 0.4 0.1 0.4 0.1
lookup
Main 209
22447632 7.2 2.6 7.2 2.6
parsegrid
Main 192
95 0.0 0.0 0.6 0.7
assign
Main 198
7695 0.0 0.0 0.6 0.7
eliminate
Main 201
51054 0.2 0.5 0.6 0.7
lookup
Main 202
1239860 0.4 0.1 0.4 0.1
lookup
Main 200
1953 0.0 0.0 0.0 0.0
... (more innocuous stuff)
More information about the Haskell-Cafe
mailing list