Haskellで数独ソルバーを書く

よくある題材。

Haskellの深さ優先探索

Haskellではシンプルに深さ優先探索が書けるので、これを使って数独ソルバを作る。というかこれを使いたくて数独ソルバーを書いた。
この関数に面食らってしまったときは、>>=を「fmapしてjoin」と読み替えると理解しやすいかもしれない。

dfs :: (a -> [a]) -> a -> [a]
dfs f x = x : (f x >>= dfs f)

数独を解く過程をツリー構造に写す

まずは脳の体操だ。探索で数独を解くには、「数独を解く」というよりは「ある数独の状態を発展させて得られるケースを列挙して、目的に沿った（＝全てのマスが埋まっている）状態のみを選択する」と考えるのが簡単だ。状態の発展の連続は、ツリー構造が想像しやすい。

状態1
　├ 状態1-2 - 状態1のうち1マスを埋めたやつ
　├ 状態1-3 - 状態1のうち1マスを埋めたやつ
　│　└ 状態1-3-1 - 状態1-3のうち1マスを埋めたやつ
　│　　　└ 状態1-3-1-1 - 略
　└ 状態1-4 - 略

すなわちdfsの引数a -> [a]を、「ある数独の状態を受け取って、適当に1マス埋めた複数の状態を返す」と読む。

そうすると、大雑把には下のtentativesを実装することになる。わざわざElementを作っているのは見やすさのためだ。Intでも全く困らない。Zeroは空きマスを表し、他は対応する数字が埋まっているマスを表す。

tentativesは、ある状態を受け取って、その1マスに仮置きをした複数の状態を返す関数になるはずだ。

data Element = Zero | One | Two | Three | Four | Five | Six | Seven | Eight | Nine
    deriving (Enum, Eq, Ix, Ord)

type Table = [[Element]]

solve :: Table -> [Table]
solve = filter isCompleted . dfs tentatives

isCompleted :: Table -> Bool
isCompleted = (all . all) (/= Zero)

tentatives :: Table -> [Table]
tentatives table = undefined

tentativesに求められる性質は2つある。1つは、仮置きは数独のルールに従って行うことだ。そうしなければ、正しい数独の状態のツリーを作れない。もう1つは、返す複数の状態は必ず正解を含んでいることだ。そうしなければ、正解の状態がツリーに残らず、最終的に全てのマスが埋まっている状態が見つからなくなってしまう。
また、深さ優先探索は全探索であるため、現実的な時間で探索を終えるには枝刈りが必要だ。最終的に生成されるツリーが、なるべく一直線になるようにtentativesを実装する。

あとはゴリゴリ書くだけ

上の作業で、数独のルールに沿って適当に仮置きするだけで数独の問題を解けるようになった。仮置きのやり方は何でもいいが、ここではあるマスに注目してそこに埋められる数字を仮置きする関数を作ることにした。

-- あるマスに空きマスに注目して、そこに埋められる数字を仮置きする。
tentatives :: Table -> [Table]
tentatives table = do
    ((x, y), cands) <- maybeToList $ minimumCandidates table
    replaceWith2 x y table <$> cands

-- 候補となる数字が最も少ないマスを選んでその候補を列挙する
minimumCandidates :: Table -> Maybe ((Int, Int), [Element])
minimumCandidates table = do
    let getPosWithCands t p@(x, y) = (p, candidates x y t)
        posWithCands = getPosWithCands table <$> posBlank table
        comp = compare `on` length . snd
    guard $ (not . null) posWithCands
    return $ minimumBy comp posWithCands

-- 安全な(!!)
(!?) :: [a] -> Int -> Maybe a
xs !? n
    | n < length xs = Just $ xs !! n
    | otherwise = Nothing

-- (x, y)に入る可能性のある数を列挙する
-- 入力に問題がある場合、空のリストを返す
candidates :: Int -> Int -> Table -> [Element]
candidates x y table = do
    existing <- maybeToList $ do
        r <- row y table
        c <- col x table
        b <- box x y table
        return $ r ++ c ++ b
    filter (`notElem` existing) [One .. Nine]

row :: Int -> Table -> Maybe [Element]
row y = (!? y)

col :: Int -> Table -> Maybe [Element]
col x = mapM (!? x)

box :: Int -> Int -> Table -> Maybe [Element]
box x y t =
    let ret = f y t >>= f x
     in ret <$ (guard $ length ret == 9)
    where
    f n = take 3 . drop (n `div` 3 * 3)

-- 数字の埋まっていないマスを列挙する
posBlank :: Table -> [(Int, Int)]
posBlank t = do
    (y, r) <- withIndex t
    (x, c) <- withIndex r
    guard $ Zero `elem` r && c == Zero
    return (x, y)

-- インデックスつきリスト
withIndex :: [a] -> [(Int, a)]
withIndex = zip [0..]

-- 指定したインデックスの値を入れ替えるやつの二次元版。部分関数。
replaceWith2 :: Int -> Int -> [[a]] -> a -> [[a]]
replaceWith2 x y t a = replaceWith y t l
    where
    l = replaceWith x (t !! y) a

-- 指定したインデックスの値を置き換える
replaceWith :: Int -> [a] -> a -> [a]
replaceWith n l a = splitAt n >>> second tail >>> uncurry (inbetween a) $ l

inbetween :: a -> [a] -> [a] -> [a]
inbetween a h t = h ++ a : t

できた。

まとめ

結局泥臭い実装になってしまったのが残念だったが、「数独を解く」という問題を「数独の問題の状態を一つ進める」というより簡単な問題にできた点は良かったと思う。dfsを使って何かを書きたいという目的も満たせた。
試しに、最も難しい数独でググったら出てきた問題を解かせてみよう。この問題は、"World's Hardest Sudoku"でググると出てくる。

>>> let pp = mapM_ print . (fmap . fmap) fromEnum
>>>     inkala2012 =
>>>         [ [8,0,0,0,0,0,0,0,0]
>>>         , [0,0,3,6,0,0,0,0,0]
>>>         , [0,7,0,0,9,0,2,0,0]
>>>         , [0,5,0,0,0,7,0,0,0]
>>>         , [0,0,0,0,4,5,7,0,0]
>>>         , [0,0,0,1,0,0,0,3,0]
>>>         , [0,0,1,0,0,0,0,6,8]
>>>         , [0,0,8,5,0,0,0,1,0]
>>>         , [0,9,0,0,0,0,4,0,0]
>>>         ]
>>> mapM_ pp $ solve $ (fmap . fmap) toEnum inkala2012
[8,1,2,7,5,3,6,4,9]
[9,4,3,6,8,2,1,7,5]
[6,7,5,4,9,1,2,8,3]
[1,5,4,2,3,7,8,9,6]
[3,6,9,8,4,5,7,2,1]
[2,8,7,1,6,9,5,3,4]
[5,2,1,9,7,4,3,6,8]
[4,3,8,5,2,6,9,1,7]
[7,9,6,3,1,8,4,5,2]

解けた。