数独ソルバー ref: http://qiita.com/items/9b55b95ba76e888032de

sudoku_solver.hs

import Data.Char
import Data.List
import Data.Array
import System.Environment (getArgs)

type Board = Array (Int,Int) Int
type BFilter = Array (Int,Int) [Int]
width = 9

toLine :: String -> [Int]
toLine ('_':cs) = -1 : toLine cs
toLine (x:cs) = digitToInt x : toLine cs
toLine "" = []

fromLine :: [Int] -> String
fromLine (-1:ns) = '_' : fromLine ns
fromLine (x:ns) = intToDigit x : fromLine ns
fromLine [] = ""

printBoard :: Board -> IO ()
printBoard = mapM_ putStrLn . makeBoxedList width . fromLine . elems

makeBoxedList :: Int -> [a] -> [[a]]
makeBoxedList _ [] = []
makeBoxedList n as = [b] ++ makeBoxedList n bs
  where (b,bs) = splitAt n as

solve :: Board -> Board
solve b = case length numList of
  0 -> b
  _ -> solve $ update b numList
  where numList = singleFilter . updateFilter makeFullNumMap . concat . map makeFilter . noneEmptyFilter $ b

makeFullNumMap :: BFilter
makeFullNumMap = listArray ((0, 0), (width-1, width-1)) $ cycle [[1..width]]

noneEmptyFilter :: Board -> [((Int,Int),Int)]
noneEmptyFilter = filter (\(_,z)->z/=(-1)) . assocs

makeFilter :: ((Int,Int),Int) -> [((Int,Int),Int)]
makeFilter p = acrossFilter p `union` downFilter p `union` groupFilter p `union` hereFilter p
  where
    acrossFilter :: ((Int,Int),Int) -> [((Int,Int),Int)]
    acrossFilter ((_,y),v) = map (\x -> ((x,y),v)) [0..width-1]

    downFilter :: ((Int,Int),Int) -> [((Int,Int),Int)]
    downFilter ((x,_),v) = map (\y -> ((x,y),v)) [0..width-1]

    groupFilter :: ((Int,Int),Int) -> [((Int,Int),Int)]
    groupFilter ((x,y),v) = zip (zip [x'..x'+2] [y'..y'+2]) (cycle [v])
      where (x',y') = ((x `div` 3) * 3, (y `div` 3) * 3)

    hereFilter :: ((Int,Int),Int) -> [((Int,Int),Int)]
    hereFilter ((x,y),_) = zip (cycle [(x,y)]) [1..width]

singleFilter :: BFilter -> [((Int,Int),Int)]
singleFilter = map (\(u,v)->(u,head v)) . filter (\(_,v)->length v==1) . assocs

updateFilter :: BFilter -> [((Int,Int),Int)] -> BFilter
updateFilter = accum (\x y -> filter (y/=) x)

update :: Board -> [((Int,Int),Int)] -> Board
update = accum (\_ a -> a)

main = do 
  content <- readFile =<< fmap head getArgs
  let problem = listArray ((0, 0), (width-1, width-1)) $ concat $ map toLine $ lines content
  putStrLn "Here is a problem:"
  printBoard $ problem
  putStrLn "\nThe answer is:"
  printBoard $ solve problem

出力例

~$ ./sudoku_solver sudoku/free_problem1.txt 
Here is a problem:
__61_7__8
8____674_
1_7832_59
_29561___
5_1__89_3
____2_16_
__5614387
78__954_6
6147_3_92

The answer is:
956147238
832956741
147832659
329561874
561478923
478329165
295614387
783295416
614783592