Re: [Haskell-cafe] Norvig's Sudoku Solver in Haskell
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) I've put up his version on hpaste : http://hpaste.org/2452#a1 Manu On Aug 26, 2007, at 10:56 PM, Daniel Fischer wrote:
Without much thinking I can spped it up by a factor of 4 (from 280s to 60s). The most important things are: - don't use length unless you need it instead of newV2 <- case length newCell of 0 -> Nothing ... and case length dPlaces of 0 -> ... use case newCell of [] -> Nothing [d'] -> ... and case dPlaces of [] -> Nothing [s'] -> ...
- let dPlaces = [ s' | u <- lookup s units, s' <- u, elem d (lookup s' newV2)] is bad let dPlaces = [s' | s' <- lookup s peers, elem d (lookup s' newV2)] scans each peer only once
- search is really bad, you lookup all squares several times, potentially compute all lengths multiple times... much better is
search :: Grid -> Maybe Grid search g = case [(l,a) | a@(_,xs) <- M.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]
(I also changed the type, and instead of foldl' you should use foldr, since "some" is lazy in the second argument, further, since Maybe is a MonadPlus, it's "mplus" and 'foldr mplus Nothing' is msum)
- Maps aren't good here, too slow lookup and you know the keys, so use arrays
On Monday 27 August 2007 09:09:17 manu wrote:
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)
I've put up his version on hpaste : http://hpaste.org/2452#a1
You shouldn't have any problem writing a purely functional solver that is faster and much shorter than Norvig's Python without having to use arrays. The following purely functional OCaml solver is faster than Norvig's, for example, and uses lists, tuples and maps: open List let invalid (i, j) (i', j') = i=i' || j=j' || i/3=i'/3 && j/3=j'/3 let select p n p' ns = if invalid p p' then filter ((<>) n) ns else ns let cmp (_, l1) (_, l2) = compare (length l1) (length l2) let add p n sols = sort cmp (map (fun (p', ns) -> p', select p n p' ns) sols) module Map = Map.Make(struct type t = int * int let compare = compare end) let rec search f sol = function | [] -> f sol | (p, ns)::sols -> iter (fun n -> search f (Map.add p n sol) (add p n sols)) ns -- Dr Jon D Harrop, Flying Frog Consultancy Ltd. OCaml for Scientists http://www.ffconsultancy.com/products/ocaml_for_scientists/?e
Am Montag, 27. August 2007 11:24 schrieb Jon Harrop:
On Monday 27 August 2007 09:09:17 manu wrote:
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)
I've put up his version on hpaste : http://hpaste.org/2452#a1
You shouldn't have any problem writing a purely functional solver that is faster and much shorter than Norvig's Python without having to use arrays.
Probably not, but what's wrong with using arrays (here and in general)? Here I find arrays very natural, after all a grid has a fixed set of indices. And as they have a much faster lookup than maps (not to mention lists), what do you gain by avoiding them?
The following purely functional OCaml solver is faster than Norvig's, for example, and uses lists, tuples and maps:
<snip> Since I don't speak OCaml, could you translate it to haskell? Cheers, Daniel
On Monday 27 August 2007 11:54:20 you wrote:
Am Montag, 27. August 2007 11:24 schrieb Jon Harrop:
You shouldn't have any problem writing a purely functional solver that is faster and much shorter than Norvig's Python without having to use arrays.
Probably not, but what's wrong with using arrays (here and in general)? Here I find arrays very natural, after all a grid has a fixed set of indices. And as they have a much faster lookup than maps (not to mention lists), what do you gain by avoiding them?
Elegance, brevity and (for short implementations) performance. Although this algorithm certainly involves getting and setting puzzle entries from a square array, there is little benefit in constraining your solver to reflect that explicitly in its concrete data structures. Compilers like GHC will be extremely good at performing low-level optimizations on list-intensive algorithms. So the performance overhead of using lists rather than arrays in a functional language will be small. Externally, using lists makes it easier to pluck out one choice and the remaining choices when searching. That is, after all, the core of this algorithm.
The following purely functional OCaml solver is faster than Norvig's, for example, and uses lists, tuples and maps:
<snip> Since I don't speak OCaml, could you translate it to haskell?
I don't speak Haskell yet but I can translate it into English: A puzzle is represented by an association list that maps each coordinate onto its possible solutions. Initially, coordinates set in the puzzle map onto singleton lists (e.g. ((3, 4), [7]) means position 3,4 in the solution must contain 7) and unset coordinates map onto [1..9]. To search for a solution, you accumulate the solution in another association list (e.g. ((3, 4), 7) means that 3,4 contains 7 in the solution). You take the coordinate with the shortest list of possibilities first and the list of remaining coordinates. You try each of the possibilities listed in turn, pushing that choice onto the current solution and filtering out all invalidated solutions from the remaining list before recursing. That's it. Choosing the shortest list first corresponds to constraint propagation. -- Dr Jon D Harrop, Flying Frog Consultancy Ltd. OCaml for Scientists http://www.ffconsultancy.com/products/ocaml_for_scientists/?e
Am Montag, 27. August 2007 14:40 schrieb Jon Harrop:
Probably not, but what's wrong with using arrays (here and in general)? Here I find arrays very natural, after all a grid has a fixed set of indices. And as they have a much faster lookup than maps (not to mention lists), what do you gain by avoiding them?
Elegance, brevity and (for short implementations) performance. Although this algorithm certainly involves getting and setting puzzle entries from a square array, there is little benefit in constraining your solver to reflect that explicitly in its concrete data structures.
I'm not convinced (yet). Elegance: well, yes in general; if you don't know the size of the problem in advance certainly. But here? Brevity: okay, "Map.fromList" is shorter than "array ((0,0),(8,8))", but not awfully much so, and you write "grid!s" regardless of whether grid is a Map or an array. So without further elaboration I remain unconvinced of that point. Performance: in my experience arrays are usually much faster (if the algorithm is suited to using them, if not, it's a different story, of course).
Compilers like GHC will be extremely good at performing low-level optimizations on list-intensive algorithms. So the performance overhead of using lists rather than arrays in a functional language will be small.
That VERY MUCH depends. I usually use lists for the Project Euler problems first (1. I love lists, 2. list code is often far more natural - and hence more elegant) and sometimes afterwards re-code it using arrays (boxed arrays or ST(U)Arrays). More often than not that reduces run time by orders of magnitude(factors between 10 and 100 are common, larger or smaller factors occur). I doubt it's just that my array code is better suited for GHC's optimiser than my list code. Maps I found to perform in between and they are rather memory-hungry.
Externally, using lists makes it easier to pluck out one choice and the remaining choices when searching. That is, after all, the core of this algorithm.
Just to make it clear, you are here talking about the list of possibilities for some square? Or are you talking about using a list of (square, list of possibilites) pairs? If the former: I represent the grid as an Array (Char,Char) [Char], replacing the original representation as a Map String [Char], so I keep that. Although, in my own solver I keep the set of possibilities for each square as an EnumSet (now Data.Set.Enum in the collections package, maybe I should update my code), that gains a factor of 2 over lists for the good old 9x9 grids, more than 10 for 16x16 grids, I fear trying 25x25 grids. However, I use deduction strategies that involve forming unions and differences of several sets of possibilities, operations which are weak spots of lists.
The following purely functional OCaml solver is faster than Norvig's, for example, and uses lists, tuples and maps:
<snip> Since I don't speak OCaml, could you translate it to haskell?
I don't speak Haskell yet but I can translate it into English:
A puzzle is represented by an association list that maps each coordinate onto its possible solutions. Initially, coordinates set in the puzzle map onto singleton lists (e.g. ((3, 4), [7]) means position 3,4 in the solution must contain 7) and unset coordinates map onto [1..9].
To search for a solution, you accumulate the solution in another association list (e.g. ((3, 4), 7) means that 3,4 contains 7 in the solution). You take the coordinate with the shortest list of possibilities first and the list of remaining coordinates. You try each of the possibilities listed in turn, pushing that choice onto the current solution and filtering out all invalidated solutions from the remaining list before recursing.
That's it. Choosing the shortest list first corresponds to constraint propagation.
Thought it was something like that. Must check whether that beats Norvig's constraint propagation. Cheers, Daniel
For the translation of the above OCaml code, there is not much to do, in fact it is mostly functional, and so easily translated in Haskell code, note that I add a code to handle input of the form "4.....8.5.3..........7......2.....6.....8.4......1.......6.3.7.5..2.....1.4......", to resolve it and print a solution : <haskell> import Data.Ix import Data.List import Data.Char import qualified Data.Map as M invalid :: (Int, Int) -> (Int, Int) -> Bool invalid (i, j) (i', j') = i==i' || j==j' || (i `div` 3 == i' `div` 3 && j `div` 3 == j' `div` 3) select p n p' ns = if invalid p p' then filter (/= n) ns else ns cmp (_, l1) (_, l2) = (length l1) `compare` (length l2) add p n sols = sortBy cmp $ map (\(p', ns) -> (p', select p n p' ns)) sols search f sol [] = f sol search f sol ((p, ns):sols) = concatMap (\n -> search f (M.insert p n sol) (add p n sols)) ns </haskell> My additions : <haskell> base :: [((Int, Int),[Int])] base = [((i,j), [1..9]) | i <- [0..8], j <- [0..8]] createBoard input = foldr constraint (M.empty, purge base input) input where constraint (p, [n]) (sol,sols) = (M.insert p n sol,add p n sols) purge b i = filter (maybe True (const False) . flip lookup i . fst) b inputBoard :: String -> [((Int, Int), [Int])] inputBoard = filter (not . null . snd) . zip (range ((0,0),(8,8))) . map (\c -> if isDigit c then [read [c]] else []) showSol = unlines . concat . intersperse ([replicate 15 '-']) . split 3 . map (unwords . intersperse "|" . split 3) . split 9 . map (chr . (+ ord '0')) . M.elems where split n = takeWhile (not . null) . unfoldr (Just . splitAt n) solve = head . uncurry (search ((:[]).showSol)) . createBoard . inputBoard main = interact $ solve </haskell> -- Jedaï
chaddai.fouche:
For the translation of the above OCaml code, there is not much to do, in fact it is mostly functional, and so easily translated in Haskell code, note that I add a code to handle input of the form "4.....8.5.3..........7......2.....6.....8.4......1.......6.3.7.5..2.....1.4......", to resolve it and print a solution :
Spencer Janssen also wrote a rather elegant translation, which you can find on hpaste.org import Data.List import Data.Ord n = 3 :: Int invalid (i, j) (i', j') = i == i' || j == j' || i `div` n == i' `div` n && j `div` n == j' `div` n select p n p' ns | invalid p p' = filter (/= n) ns | otherwise = ns add p n sols = sortBy (comparing (length . snd)) $ map f sols where f (p', ns) = (p', select p n p' ns) search [] = [[]] search ((p, ns):sols) = [(p, n):ss | n <- ns, ss <- search $ add p n sols] You can see the development here, http://hpaste.org/2348 -- Don
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
participants (5)
-
Chaddaï Fouché -
Daniel Fischer -
dons＠cse.unsw.edu.au -
Jon Harrop -
manu