Haskellで数独を解いてみた
関数プログラミング実践入門を読んだのでHaskellで数独を解いてみました。実装は以下のようになりました。
module Try.Sudoku where
import Data.List
import Data.Function
type Cell = (Int, Int)
type Board = [(Cell, Int)]
solve :: Board -> [Board]
solve board | length board == 81 = [board]
solve board = do
concat $ map solve [ (cell, n) : board
| let remains = concat $ (\x -> if x `elem` map (\x -> fst x) board then [] else [x]) <$> cells
, let cell = maximumBy (compare `on` length . used board) remains
, n <- concat $ (\x -> if x `elem` used board cell then [] else [x]) <$> [1..9]]
cells :: [Cell]
cells = [(x, y) | x <- [0..8], y <- [0..8]]
area :: Cell -> Int
area (x, y) = y `div` 3 * 3 + x `div` 3
used :: Board -> Cell -> [Int]
used board cell = nub [ n
| (cell', n) <- board
, any (\f -> f cell == f cell') [snd, fst, area]
]
sudokuAns :: IO ()
sudokuAns = case solve problem of
answer : _ -> mapM_ print $ format answer
[] -> putStrLn "invalid problem"
format :: Board -> [[Int]]
format = map (map snd) . transpose . groupBy ((==) `on`(fst . fst)) . sort
problem :: Board
problem = [ ((3, 0), 8),
((5, 0), 1),
((6, 1), 4),
((7, 1), 3),
((0, 2), 5),
((4, 3), 6),
((6, 3), 8),
((6, 4), 1),
((1, 5), 2),
((4, 5), 3),
((0, 6), 6),
((7, 6), 7),
((8, 6), 5),
((2, 7), 3),
((3, 7), 4),
((3, 8), 2),
((6, 8), 6)
]
main :: IO ()
main = do
sudokuAns
各セルとボードの情報を表すための型シノニムを定義します。
type Cell = (Int, Int) type Board = [(Cell, Int)]
ボード上には9 × 9のセルが並び、各セルを初期化する場合は以下のようになります。
cells :: [Cell] cells = [(x, y) | x <- [0..8], y <- [0..8]]
問題となる数独のボードは以下のように表せられます。
problem :: Board
problem = [ ((3, 0), 8),
((5, 0), 1),
((6, 1), 4),
((7, 1), 3),
((0, 2), 5),
((4, 3), 6),
((6, 3), 8),
((6, 4), 1),
((1, 5), 2),
((4, 5), 3),
((0, 6), 6),
((7, 6), 7),
((8, 6), 5),
((2, 7), 3),
((3, 7), 4),
((3, 8), 2),
((6, 8), 6)
]
((3, 0), 8) は四行一列目が8で埋められていることを表し、リストを使ってすでに埋められている数値を表しています。
数独では3×3の区間で数値が被らないようにする必要があるので、対象のセルが3×3のどの区間に存在しているか判定するために以下の関数を定義します。
area :: Cell -> Int area (x, y) = y `div` 3 * 3 + x `div` 3
ボードとセルを指定して、対象のセルに入る値の候補を取得できるようにするため以下の関数ではすでに使われている数値を取得します。
used :: Board -> Cell -> [Int]
used board cell = nub [ n
| (cell', n) <- board
, any (\f -> f cell == f cell') [snd, fst, area]
]
リスト内包表記を使って入る値の候補を取得しますが重複を除去するためにnubを使っています。 nubを使うと以下のようにリスト内の重複を除去してくれます。
ghci>[n | n <- [0,1,2,2,3,4,5]] [0,1,2,2,3,4,5] ghci>nub [n | n <- [0,1,2,2,3,4,5]] [0,1,2,3,4,5]
(cell', n) <- boardで引数で渡したボードを扱いやすくするようにセルと値に分けています。 any (\f -> f cell == f cell') [snd, fst, area]では指定したセルの縦、横、3×3の区間ですでに使用されているものでフィルターをかけています。anyは関数とリストを受け取り、リスト内の各要素に関数適応後に一つでもTrueを返すものがあれば結果がtrueとなります。
ghci>any (\a -> a == 1) [1, 2, 3] True
フィルターをかけた後にすでに使われている数値の重複を除去するためnubを使っています。
問題を解いているメインの関数は以下になります。
solve :: Board -> [Board]
solve board | length board == 81 = [board]
solve board = do
concat $ map solve [ (cell, n) : board
| let remains = concat $ (\x -> if x `elem` map (\x -> fst x) board then [] else [x]) <$> cells
, let cell = maximumBy (compare `on` length . used board) remains
, n <- concat $ (\x -> if x `elem` used board cell then [] else [x]) <$> [1..9]]
数独には複数の回答がありえるため関数の型はsolve :: Board -> [Board]となっております。処理の大まかな流れはボード上で埋められる数の候補が一番多いセルを取得ごにそれぞれのセル埋めた場合で処理を分岐させるのを繰り返し、ボード上の全てのセルが埋まったら答えの一つとして返すというようになっています。
セルが全て埋まっているかどうかは以下で判定しています。
solve board | length board == 81 = [board]
それから以下の関数で再帰的にセルを埋めています。
solve board = do
concat $ map solve [ (cell, n) : board
| let remains = concat $ (\x -> if x `elem` map (\x -> fst x) board then [] else [x]) <$> cells
, let cell = maximumBy (compare `on` length . used board) remains
, n <- concat $ (\x -> if x `elem` used board cell then [] else [x]) <$> [1..9]]
リスト内包表記では引数で与えられたボードの先頭に一つ埋めたセルを追加するようにしています。[ (cell, n) : board | ,,,]それからmap solve を適用することで再帰的に処理を呼び出すようにしています。最後にconcatを使うことでboard型から[board]型に変換しています。
ghci>concat $ [[0..3],[4..5]] [0,1,2,3,4,5]
リスト内包表記の中身についてみていきます。
let remains = concat $ (\x -> if x `elem` map (\x -> fst x) board then [] else [x]) <$> cells
についてはremainsにまだ埋められていないcellを代入しています。
let cell = maximumBy (compare `on` length . used board) remains
まだ数値が埋められていないセルの中で入る値の候補が一番多いものを取得しています。
n <- concat $ (\x -> if x `elem` used board cell then [] else [x]) <$> [1..9]]
それから上記の処理により、入る値の候補のみを取得しています。よってこのリスト内包表記ではまだ埋められていないセルのうち入る値の候補が一番多いセルの各値の候補をボードの先頭に追加したボードのリストを返しています。
回答結果の表示は以下の処理になります。
sudokuAns :: IO ()
sudokuAns = case solve problem of
answer : _ -> mapM_ print $ format answer
[] -> putStrLn "invalid problem"
format :: Board -> [[Int]]
format = map (map snd) . transpose . groupBy ((==) `on`(fst . fst)) . sort
sudokuAns関数のcase式によりリストのうちの最初の回答のみを評価して表示するようにしています。
実行すると以下のように回答結果が表示されます。
[3,6,9,8,4,1,7,5,2] [2,7,8,6,9,5,4,3,1] [5,1,4,3,2,7,9,8,6] [7,3,1,5,6,4,8,2,9] [4,9,5,7,8,2,1,6,3] [8,2,6,1,3,9,5,4,7] [6,4,2,9,1,8,3,7,5] [1,5,3,4,7,6,2,9,8] [9,8,7,2,5,3,6,1,4]
また、この回答方法は複数回答ある場合は先頭一つを取り出すようになっているので高速に結果を返していますが、時間をかけて全ての件数を取得することもできます。
print $ length $ solve problem 19283
