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 _______________________________________________ Haskell-Cafe mailing list Haskell-Cafe@haskell.org http://www.haskell.org/mailman/listinfo/haskell-cafe