Daniel Fischer daniel.is.fischer at web.de
Mon Aug 27 15:52:09 EDT 2007

```Am Montag, 27. August 2007 10:09 schrieb manu:
> Daniel Fischer's modifications to my original program lead to a 400 %
> speed boost !!!
> (It now runs in 22 seconds on my machine)
> He avoided unecessary calls to 'length', uses Array instead of Map,
> refactored 'search' function (details below)
>

Ouch! I should've looked at the code more closely.
That had a bug which resulted in LOTS of futile work.
Fixed that and the Array version now runs in 3 seconds on my computer
(previous version took 60), the corresponding Map version runs in 7.

What was the saying, 'The best optimisation is a better algorithm'?

Code below.

Cheers,
Daniel

{-

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 Data.List hiding (lookup)
import Data.Array
import Data.Maybe

--------------------------------------------------
-- Types
type Digit  = Char
type Square = (Char,Char)
type Unit   = [Square]

-- We represent our grid as an array
type Grid = Array Square [Digit]

--------------------------------------------------
-- Setting Up the Problem

rows = "ABCDEFGHI"
cols = "123456789"
digits = "123456789"
box = (('A','1'),('I','9'))

cross :: String -> String -> [Square]
cross rows cols = [ (r,c) | r <- rows, c <- cols ]

squares :: [Square]
squares = cross rows cols  -- [('A','1'),('A','2'),('A','3'),...]

peers :: Array Square [Square]
peers = array box [(s, set (units!s)) | s <- squares ]
where
set = nub . concat

unitlist :: [Unit]
unitlist = [ cross rows [c] | c <- cols ] ++
[ cross [r] cols | r <- rows ] ++
[ cross rs cs | rs <- ["ABC","DEF","GHI"], cs <-
["123","456","789"]]

-- this could still be done more efficiently, but what the heck...
units :: Array Square [Unit]
units = array box [(s, [filter (/= s) u | u <- unitlist, elem s u ]) | s <-
squares]

allPossibilities :: Grid
allPossibilities = array box [ (s,digits) | s <- squares ]

--------------------------------------------------
-- Parsing a grid into a Map

parsegrid     :: String -> Maybe Grid
parsegrid g    = do regularGrid g
foldM assign allPossibilities (zip squares g)

where  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 ds = g!s
toDump = delete d ds
foldM eliminate g (zip (repeat s) toDump)
else return g

eliminate     ::  Grid -> (Square, Digit) -> Maybe Grid
eliminate g (s,d) = let cell = g!s 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 = g // [(s,newCell)]
newV2 <- case newCell of
terminates the computation
[] -> Nothing
-- if there is only one value (d')
left in square, remove it from peers
[d'] -> do let peersOfS = peers!s
foldM eliminate newV
(zip peersOfS (repeat d'))
-- else : return the new grid
_ -> return newV
-- Now check the places where d appears in the
units of s
foldM (locate d) newV2 (units ! s)

locate :: Digit -> Grid -> Unit -> Maybe Grid
locate d g u = case filter (elem d . (g !)) u of
[]  -> Nothing
[s] -> assign g (s,d)
_   -> return g

--------------------------------------------------
-- Search

search :: Grid -> Maybe Grid
search g = case [(l,(s,xs)) | (s,xs) <- assocs g, let l = length xs, l /= 1]
of
[] -> return g
ls -> do let (_,(s,ds)) = minimum ls
msum [assign g (s,d) >>= search | d <- ds]

solve :: String -> Maybe Grid
solve str = do
grd <- parsegrid str
search grd

--------------------------------------------------
-- Display solved grid

printGrid :: Grid -> IO ()
printGrid = putStrLn . gridToString

gridToString :: Grid -> String
gridToString g = let l0 = elems g
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
grids <- fmap lines \$ readFile "top95.txt"
mapM_ printGrid \$ mapMaybe solve grids

```