sudoku solver

import Data.Array
import Data.Maybe
import Data.Ord
import Data.Foldable (toList)
import Data.Char
import Data.List

type Sudoku = Array Pos (Maybe Color)
type Pos = (Int, Int)
type Color = Int

update :: Sudoku -> Pos -> Maybe Color -> Sudoku
update a i e = a // [(i, e)]

blanks :: Sudoku -> [Pos]
blanks a = filter (isNothing . (a !)) . indices $ a

adjacent :: Pos -> [Pos]
adjacent (x, y) = filter (/= (x, y)) $
    [(x, y') | y' <- [1..9]] ++
    [(x', y) | x' <- [1..9]] ++
    [(x0+x', y0+y') | x' <- [1..3], y' <- [1..3]]
    where
        x0 = ((x - 1) `div` 3) * 3
        y0 = ((y - 1) `div` 3) * 3

legal :: Sudoku -> Pos -> Color -> Bool
legal s p m = all ((/= Just m) . (s !)) . adjacent $ p

isSolved :: Sudoku -> Bool
isSolved = null . blanks

legalMoves :: Sudoku -> Pos -> [Color]
legalMoves s p = filter (legal s p) [1..9]

minBy :: (a -> a -> Ordering) -> [a] -> Maybe a
minBy _ [] = Nothing
minBy cmp xs = Just . foldl1 minBy' $ xs
    where
        minBy' x y = case x `cmp` y of
            GT -> y
            _  -> x

mostRestrictedBlank :: Sudoku -> Maybe Pos
mostRestrictedBlank s = minBy (comparing (length . legalMoves s)) . blanks $ s

branches :: Sudoku -> [Sudoku]
branches s = 
    do
        p <- toList . mostRestrictedBlank $ s
        m <- legalMoves s p
        return (update s p (Just m))

depthFirstSearch :: (a -> Bool) -> (a -> [a]) -> a -> Maybe a
depthFirstSearch done branches = go
    where 
        go x =
            if done x
            then Just x
            else listToMaybe . catMaybes . map go . branches $ x
            
solve :: Sudoku -> Maybe Sudoku
solve = depthFirstSearch isSolved branches

parseColor :: Char -> Maybe Color
parseColor c =
    if isDigit c 
    then Just . digitToInt $ c
    else Nothing

parseSudoku :: String -> Sudoku
parseSudoku = listArray ((1,1), (9,9)) . map parseColor . filter (/= '\n')

rows :: (Ix x, Ix y) => Array (x, y) e -> [[e]]
rows a = [[a ! (x, y) | y <- range (y0, y1)] | x <- range (x0, x1)]
    where
        ((x0, y0), (x1, y1)) = bounds a

printColor :: Maybe Color -> Char
printColor Nothing  = ' '
printColor (Just c) = intToDigit c
        
printSudoku :: Sudoku -> String
printSudoku = intercalate "\n" . map (map printColor) . rows

printSolution :: Maybe Sudoku -> String
printSolution = fromMaybe "Unsolvable" . fmap printSudoku
    
puzzle :: Sudoku
puzzle = parseSudoku "   8 95 3\n   7    4\n857  31  \n 6 3    2\n  8   9  \n7    2 6 \n  56  248\n2    7   \n3 42 8   "

main = do
    putStr . printSolution . solve $ puzzle