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

```