[Haskell-cafe] Norvig's Sudoku Solver in Haskell

[Daniel Fischer]

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 Control.Monad
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
                                            -- contradiction : Nothing 
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