--
-- 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 '-'