-- -- Sudoku solver using constraint propagation. The algorithm is by -- Peter Norvig http://norvig.com/sudoku.html; the Haskell -- implementation is by Manu and Daniel Fischer, and can be found on -- the Haskell Wiki http://www.haskell.org/haskellwiki/Sudoku -- -- The Haskell wiki license applies to this code: -- -- Permission is hereby granted, free of charge, to any person obtaining -- this work (the "Work"), to deal in the Work without restriction, -- including without limitation the rights to use, copy, modify, merge, -- publish, distribute, sublicense, and/or sell copies of the Work, and -- to permit persons to whom the Work is furnished to do so. -- -- THE WORK IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -- LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -- OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -- WITH THE WORK OR THE USE OR OTHER DEALINGS IN THE WORK. module Sudoku (solve, printGrid) 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, s `elem` u ]) | s <- squares] allPossibilities :: Grid allPossibilities = array box [ (s,digits) | s <- squares ] -- Parsing a grid into an Array parsegrid :: String -> Maybe Grid parsegrid g = do regularGrid g foldM assign allPossibilities (zip squares g) where regularGrid :: String -> Maybe String regularGrid g = if all (`elem` "0.-123456789") g then Just g else Nothing -- Propagating Constraints assign :: Grid -> (Square, Digit) -> Maybe Grid assign g (s,d) = if d `elem` digits -- check that we are assigning a digit and not a '.' then do 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 d `notElem` 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 left in s, 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 peers of s foldM (locate d) newV2 (units ! s) locate :: Digit -> Grid -> Unit -> Maybe Grid locate d g u = case filter ((d `elem`) . (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 -- [("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 = ys : sublist n zs where (ys,zs) = splitAt n xs line = hyphens ++ "+" ++ hyphens ++ "+" ++ hyphens hyphens = replicate 9 '-'