数独Solver

Sudoku.hs

import Data.List
import Control.Monad.Reader
import Control.Monad.Writer
import Data.Maybe

-- Pair of row and column
type Position = (Int, Int)
-- Pair of Position and possible numbers
type Cell = (Position, [Int])
-- List of Cell
type Board = [Cell]

numbers = [1, 2, 3, 4, 5, 6, 7, 8, 9]

{-
Parse input into Board. Input has format like 'positionX postitionY Number'.
Eg.
1 1
1 2 5
1 3
...
 -}
parseBoard :: [String] -> Board
parseBoard xs = map doParseBoard xs
  where doParseBoard input = let inputs = map read . words $ input
                                 x = inputs !! 0
                                 y = inputs !! 1
                                 remain = snd $ splitAt 2 inputs
                             in ((x,y), remain)

rowAt :: Position -> Board -> [Cell]
rowAt (x, y) board = filter (\((px, py), _) -> px == x) board

colAt :: Position -> Board -> [Cell]
colAt (x, y) board = filter (\((px, py), _) -> py == y) board

boxAt :: Position -> Board -> [Cell]
boxAt (x, y) board = filter (\((px, py), _) -> px `elem` bx && py `elem` by) board
  where bx = rangeThree x
        by = rangeThree y
        rangeThree n
          | n < 4     = [1, 2, 3]
          | n < 7     = [4, 5, 6]
          | n < 10    = [7, 8, 9]
          | otherwise = error "Invalid number"

getNumber :: Cell -> Maybe Int
getNumber (_, [x]) = Just x
getNumber (_, _)   = Nothing

setNumber :: [Int] -> Position -> Board -> Board
setNumber nums position board = let (former, _:latter) = break (\(p, _) -> p == position) board
                                in former ++ ((position, nums):latter)

getNumberFromPosition :: Position -> Board -> Maybe [Int]
getNumberFromPosition position board = (find (\(p, _) -> p == position) board) >>= (\x -> return $ snd x)

solved :: Board -> Bool
solved board = length (filter (\(p, xs) -> length xs /= 1) board) == 0

{- Solution 1 -}

appearRow :: Position -> Board -> [Int]
appearRow position board = catMaybes $ map getNumber $ rowAt position board

appearCol :: Position -> Board -> [Int]
appearCol position board = catMaybes $ map getNumber $ colAt position board

appearBox :: Position -> Board -> [Int]
appearBox position board = catMaybes $ map getNumber $ boxAt position board

-- Collect possible numbers in the position
candidate :: Position -> Board -> [Int]
candidate position board = numbers \\ appears
  where appears = runReader r board
        r = do
          n1 <- reader $ appearRow position
          n2 <- reader $ appearCol position
          n3 <- reader $ appearBox position
          return (n1 `union` n2 `union` n3)

scanCandidate :: Board -> Board
scanCandidate board = map doScan board
  where doScan (p, [x]) = (p, [x])
        doScan (p, _)   = (p, candidate p board)

-- Solve Sudoku by `scanCandidate`
solveSudoku1 :: Board -> Board
solveSudoku1 board
  | solved board = board
  | otherwise    = solveSudoku1 (scanCandidate board)

{- Solution 2 -}

onlyInRow :: Position -> Board -> Maybe [Int]
onlyInRow position board = do
                             target <- getNumberFromPosition position board
                             let others = foldl union [] (map snd $ filter ((/=) position . fst) $ rowAt position board)
                             onlyIn target others

onlyInCol :: Position -> Board -> Maybe [Int]
onlyInCol position board = do
                             target <- getNumberFromPosition position board
                             let others = foldl union [] (map snd $ filter ((/=) position . fst) $ colAt position board)
                             onlyIn target others

onlyInBox :: Position -> Board -> Maybe [Int]
onlyInBox position board = do
                             target <- getNumberFromPosition position board
                             let others = foldl union [] (map snd $ filter ((/=) position . fst) $ boxAt position board)
                             onlyIn target others

onlyIn :: [Int] -> [Int] -> Maybe [Int]
onlyIn target others = case target \\ others of
                         [x] -> Just [x]
                         _   -> Nothing

-- Find a number which is only one possible in the position.
only :: Position -> Board -> [Int]
only position board = case result of
                        Just xs -> xs
                        Nothing -> fromJust original
  where original = getNumberFromPosition position board
        r = do
          n1 <- reader $ onlyInRow position
          n2 <- reader $ onlyInCol position
          n3 <- reader $ onlyInBox position
          return (n1 `mplus` n2 `mplus` n3 `mplus` original)
        result = runReader r board

scanOnly :: Board -> Board
scanOnly board = map doScan board
  where doScan (p, [x]) = (p, [x])
        doScan (p, xs)  = (p, only p board)

-- Solve Sudoku by `scanCandidate` and `scanOnly`
solveSudoku2 :: Board -> Board
solveSudoku2 board
  | solved board = board
  | otherwise    = solveSudoku2 (scanOnly . scanCandidate $ board)

これではいわゆる「仮置き」が必要になる問題は解けないよう。
数字の候補の中から適当に選んで埋めていく深さ優先探索が必要になる。