Skip to content

Instantly share code, notes, and snippets.

@tiqwab
Last active Aug 6, 2016
Embed
What would you like to do?
数独Solver
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)
@tiqwab

This comment has been minimized.

Copy link
Owner Author

@tiqwab tiqwab commented Aug 6, 2016

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

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment