Peter Norvig's beautiful Python program (http://norvig.com/sudoku.html) now in Haskell!

sudoku.hs

-- Peter Norvig's beautiful Python program (http://norvig.com/sudoku.html)
-- that uses constraint propagation (and ultimately searching)
-- to solve Sudoku instances
--
-- Now in everybody's favorite language!
-- Haskell coding by Ashutosh Mehra (http://ashutoshmehra.net/blog/)

import List (elem, nub, filter, delete, intersperse, replicate)
import Data.Map (Map, fromList, (!), insert, keys, elems, toList)
import Data.List (intercalate)
import Data.Maybe

type Val = Char                 -- Value of a cell
type Square = String            -- two-character square ID
type Board = Maybe (Map Square String) -- The board state

cross xs ys = [[x,y] | x <- xs, y <- ys]
rows = "ABCDEFGHI"
cols = "123456789"
digits = "123456789"
squares = cross rows cols
unitlist = [cross rows [c] | c <- cols]
           ++ [cross [r] cols | r <- rows]
           ++ [cross rs cs | rs <- ["ABC", "DEF", "GHI"], cs <- ["123","456","789"]]
units sq = filter (elem sq) unitlist
peers sq = delete sq . nub . concat $ units sq

-- Check for places where d appears in the units of sq
checkplaces :: Board -> Square -> Val -> Board
checkplaces b0 sq d = foldl f b0 (units sq)
    where f b u
              | isNothing b || len == 0 = Nothing
              | len == 1                = assign b (head dplaces) d
              | otherwise               = b
              where dplaces = [s | s <- u, elem d ((fromJust b)!s)]
                    -- dplaces is all squares in the unit u possibly containing d
                    len = length dplaces

eliminate :: Board -> Square -> Val -> Board
eliminate Nothing _ _ = Nothing
eliminate (Just b0) sq d 
    | notElem d v    = Just b0     -- Already Eliminated
    | length v' == 0 = Nothing     -- Contradiction: Removed last value
    | length v' == 1 = checkplaces b'' sq d -- Only 1 left: Remove from peers
    | otherwise      = checkplaces (Just b') sq d
    where v = b0 ! sq
          v' = delete d v
          b' = insert sq v' b0
          h = (head v')
          b'' = foldl (\b p -> eliminate b p h) (Just b') (peers sq)

assign :: Board -> Square -> Val -> Board
assign Nothing _ _ = Nothing
assign b0 sq d0 = foldl f b0 ((fromJust b0) ! sq)
    where f b d = if d0 == d then b else eliminate b sq d

parsegr :: String -> Board
parsegr s = foldl f b0 (zip squares s')
    where s' = filter (\x -> elem x "0.-123456789") s
          b0 = Just (fromList [(s, digits) | s <- squares])
          f b (sq, d) 
              | isNothing b      = Nothing
              | notElem d digits = b
              | otherwise        = assign b sq d

search :: Board -> Board
search Nothing = Nothing
search (Just b) = 
    if all ((==1) . length) $ elems b then Just b else search' (b!s)
    where minl = minimum [l | v <- elems b, let l = length v, l > 1]
          s = head [sq | (sq, v) <- toList b, length v == minl]
          search' [] = Nothing
          search' (d:ds) = if isJust b' then b' else search' ds
              where b' = search $ assign (Just b) s d

printgr :: Board -> String
printgr Nothing = "Unsolvable"
printgr (Just b) = concat [(fr r) ++ (if elem r "CF" then line else "") ++ "\n" | r<-rows]
    where w = 1 + maximum [length (b!sq) | sq <- squares]
          line = (++) "\n" $ intercalate "+" $ replicate 3 $ replicate (3 * w) '-'
          fr r = concat [(fmt (b![r,c])) ++ (if elem c "36" then "|" else "") | c<-cols]
          fmt s = s ++ replicate (w - (length s)) ' '

solve :: String -> IO ()
solve s = putStrLn $ printgr $ search $ parsegr s

-- Instance from http://programmingpraxis.com/2009/02/19/sudoku/2/
grid = "7..1......2.....15.....639.2...18....4..9..7....75...3.785.....56.....4......1..2"

main = solve grid