数独

正月にお義父さんから勧められて数独をやりました。初めてやりましたが、なかなか面白いですね。
Haskellで作ってみました。

-- Sudoku.hs

import Data.List ((\\))
import System.Environment (getArgs)

data Cell = Cell {row::Int,col::Int,val::String} deriving Show

readCSV :: String -> [[String]]
readCSV contents = map (splitCSV) $ lines contents
    where splitCSV "" = []
          splitCSV l  = let (x, y) = break (== ',') l
                        in x:splitCSV (tail' y)
          tail' ""    = ""
          tail' xs    = tail xs

makeCells :: [[String]] -> [Cell]
makeCells xs = makeCells' 0 xs
    where makeCells' _ [] = []
          makeCells' n (y:ys) = makeCell n 0 y ++ makeCells' (n + 1) ys

makeCell :: Int -> Int -> [String] -> [Cell]
makeCell _ 9 _      = []
makeCell r c []     = [Cell r c ""]
makeCell r c (x:xs) = (Cell r c x):makeCell r (c + 1) xs

h_collect :: Int -> [Cell] -> [Cell]
h_collect r xs = filter (\(Cell x _ _) -> r == x) xs

v_collect :: Int -> [Cell] -> [Cell]
v_collect c xs = filter (\(Cell _ x _) -> c == x) xs

b_collect :: Int -> Int -> [Cell] -> [Cell]
b_collect r c cells = collect cells
    where x = if r < 3 then 0 else if r < 6 then 3 else 6
          y = if c < 3 then 0 else if c < 6 then 3 else 6
          collect = filter (\(Cell r c _) -> ((x <= r) && (x + 3 > r)) && ((y <= c) && (y + 3 > c)))

eval :: [Cell] -> [Cell] -> [Cell]
eval [] ys = if check ys then ys else eval ys []
eval xss@((Cell r c vv):xs) ys = if null vv
                                then let x = Cell r c searched in eval xs (ys ++ [x])
                                else eval xs (ys ++ [Cell r c vv])
    where zs = ys ++ xss
          h = map (read' . val) (h_collect r zs) 
          v = map (read' . val) (v_collect c zs)
          b = map (read' . val) (b_collect r c zs)
          a = (([1,2..9] \\ h) \\ v) \\ b
          searched = if length a == 1 then show (head a) else ""
          read' "" = 0
          read' x  = read x

check :: [Cell] -> Bool
check = all (not . null) . map val

toStr :: Cell -> String
toStr (Cell r c v) = if c == 8 then v ++ "\n" else v ++ ","

main = do
    (f:_) <- getArgs
    exec f

exec f = do
    cells <- return . makeCells . readCSV =<< readFile f
    str <- return $ concatMap toStr $ eval cells []
    writeFile "answer.txt" str

引数にCSV形式の問題ファイルを与えます。

> runhaskell Sudoku.hs problem.txt

problem.txtはこんな感じ。

,,,,6,,,8,9
,8,1,,,,,4,5
,,4,8,,,3,7,
,,,4,5,,9,,
3,,,,,,,,1
,,5,,7,1,,,
,4,8,,,2,5,,
7,5,,,,,2,3,
9,2,,,8,,,,

answer.txtに答えが出力されます。

5,3,7,2,6,4,1,8,9
2,8,1,3,9,7,6,4,5
6,9,4,8,1,5,3,7,2
8,1,2,4,5,3,9,6,7
3,7,9,6,2,8,4,5,1
4,6,5,9,7,1,8,2,3
1,4,8,7,3,2,5,9,6
7,5,6,1,4,9,2,3,8
9,2,3,5,8,6,7,1,4