パズルの解法 (6)
今回は皆さんお馴染みのパズル「数独 (ナンバープレース)」の解法プログラムを作りましょう。本稿では「ナンプレ」と呼ぶことにします。
●ナンプレとは？
ナンプレは 9×9 の盤を用いて、縦 9 列、横 9 行のそれぞれに 1 から 9 までの数字をひとつずつ入れます。また、太線で囲まれた 3×3 の枠内にも 1 から 9 までの数字をひとつずつ入れます。ただし、縦、横、枠の中で、同じ数字が重複して入ることはありません。
パズルの解き方 [*1] ですが、基本的には次の条件を満たすマスを探して数字を確定していきます。
- 置くことができる数字がただひとつしかない場合
- 縦、横、枠の中で、数字を置くことができるマスがひとつしかない場合
(1) は簡単ですね。(2) は次の例をみてください。
置くことができる数字
--------------------------
８
Ａ [4,5,7,9]
Ｂ [4,5,7]
６
２
Ｃ [3,5,7]
１
Ｄ [4,5,9]
Ｅ [4,9]
これは縦 1 列を抜き出したものです。マス C に注目してください。C には 3, 5, 7 を置くことができるので、条件 (1) で確定することはできません。ここで縦全体を見てください。この中で、数字 3 を置くことができるのは、このマスしかありませんね。したがって、C は 3 に確定することができるのです。同じように、横の関係、枠の関係で数字を確定することができます。
条件を満たすマスを探して数字を確定していくと、そのことで新たに (1) か (2) を満たすマスが出てくるので、それを探して数字を確定します。これを繰り返すことで、ナンプレを解くことができます。本稿ではこれを「確定サーチ」と呼ぶことにします。ナンプレの多くは、この確定サーチで解くことができるのですが、実はこれでは解けない難しい問題があるのです。
このような難しい問題をどうやって解くのか、M.Hiroi には見当もつきませんが、コンピュータを使えば「試行錯誤」という力技で解を見つけることができます。つまり、適当な数字を選んでマスを埋めていき、矛盾するようであれば元に戻って違う数字を選び直せばいいわけです。まずは最初に「バックトラック」だけでプログラムを作ってみましょう。
[*1] 今回説明したナンプレの解き方は基本的なもので、ネットを検索すればナンプレの解法テクニックを解説したサイトがたくさん見つかると思います。
●単純なバックトラックによる解法
最近のパソコンはハイスペックなので、9 行 9 列盤のナンプレであれば単純なバックトラックで簡単に解くことができます。空き場所の数字を決めるとき、縦、横、枠にない数字を選択します。解けない場合は、バックトラックして異なる数字を選び直します。プログラムは次のようになります。
リスト : ナンバープレースの解法
import Data.List
import Control.Monad
-- 盤面
type Board = [[Int]]
-- 数字を取り出す
getNum :: Board -> Int -> Int -> Int
getNum board x y = (board !! y) !! x
-- 列を取り出す
getColumn :: Board -> Int -> [Int]
getColumn board n = map head $ map (drop n) board
-- (x,y) の枠を取り出す
getGroup :: Board -> Int -> Int -> [Int]
getGroup board x y = concatMap (f x') $ f y' board
where x' = x `div` 3
y' = y `div` 3
f n xs = take 3 $ drop (n * 3) xs
-- n 番目の要素を m に置き換える
substNth :: [a] -> Int -> a -> [a]
substNth [] _ _ = []
substNth (x:xs) 0 m = m : xs
substNth (x:xs) n m = x : substNth xs (n - 1) m
-- 数字を書き込む
putNum :: Board -> Int -> Int -> Int -> Board
putNum board x y n =
substNth board y $ substNth (board !! y) x n
-- 解法
solver :: Board -> [Board]
solver board = iter board makeIdx
where makeIdx = [(x,y) | y <- [0..8], x <- [0..8], getNum board x y == 0]
iter board [] = return board
iter board ((x, y):idx) = do
let xs = getColumn board x
ys = board !! y
gs = getGroup board x y
n <- [1..9]
guard(n `notElem` xs)
guard(n `notElem` ys)
guard(n `notElem` gs)
iter (putNum board x y n) idx
Board は盤面を表すデータ型です。Board のデータ型はリストのリスト [[Int]] で、[Int] が行を表します。リストの要素は 0 から 9 までの整数 (Int) で、空き場所を 0 で表します。関数 getNum board x y は盤面の座標 (x, y) にある数字を取り出します。board !! y で y 番目のリストを取り出し、その x 番目の要素を演算子 !! で取り出します。
行のデータを取り出すのは簡単ですね。盤面を board とすると、n 行のデータは board !! n で取り出すことができます。関数 getColumn は列のデータを取り出します。n 列目のデータは、各行のリストの先頭から n 個の要素を drop で取り除き、残ったリストの先頭要素を head で取り出すだけです。
関数 getGroup は座標 (x, y) が位置する枠のデータを取り出します。最初に、枠の座標 x' , y' を求めます。次に、board の先頭から y' 個のリストを取り除き、そこから 3 個のリストを取り出します。この処理を局所関数 f で行っています。次に、3 個のリストの先頭から x' 個の要素を取り除き、3 個の要素を取り出します。この処理も局所関数 f で行うことができます。あとは、concatMap で取り出したリストを連結するだけです。
関数 substNth はリストの n 番目の要素を m に置き換えます。substNth を使って、盤面 board に数字を書き込みます。この処理を関数 putNum で行います。最初に、 y 行目のリストを取り出して、その x 番目の要素を n に置き換えます。それから、そのリストを board の y 番目の要素と置き換えればいいわけです。
あとは、関数 solver で問題を解くだけです。実際の処理は局所関数 iter で行います。iter はリストモナドを使っていることに注意してください。mkIdx は空き場所の座標を求める関数です。iter で空き場所を順番に取り出し、その縦、横、枠のデータを変数 xs, ys, gs にセットします。あとは、1 から 9 までの数字を n にセットして、n が xs, ys, gs に無いことを guard で確認するだけです。
●実行例 (1)
それでは、実際に数独を解いてみましょう。
リスト : 問題 (出典: 数独 - Wikipedia の問題例)
q00 :: Board
q00 = [[5, 3, 0, 0, 7, 0, 0, 0, 0],
[6, 0, 0, 1, 9, 5, 0, 0, 0],
[0, 9, 8, 0, 0, 0, 0, 6, 0],
[8, 0, 0, 0, 6, 0, 0, 0, 3],
[4, 0, 0, 8, 0, 3, 0, 0, 1],
[7, 0, 0, 0, 2, 0, 0, 0, 6],
[0, 6, 0, 0, 0, 0, 2, 8, 0],
[0, 0, 0, 4, 1, 9, 0, 0, 5],
[0, 0, 0, 0, 8, 0, 0, 7, 9]]
*Main> mapM_ print $ head $ solver q00 [5,3,4,6,7,8,9,1,2] [6,7,2,1,9,5,3,4,8] [1,9,8,3,4,2,5,6,7] [8,5,9,7,6,1,4,2,3] [4,2,6,8,5,3,7,9,1] [7,1,3,9,2,4,8,5,6] [9,6,1,5,3,7,2,8,4] [2,8,7,4,1,9,6,3,5] [3,4,5,2,8,6,1,7,9]
ヒント (初期配置の数字) が多い問題であれば、単純な深さ優先探索でも一瞬で解を求めることができます。そこで、もう少し難しい問題を解いてみましょう。deepgreen さん が作成された ナンプレ問題集 より問題 9909-c1, 9909-d1, 9909-e1, 9909-h1, 9909-h2 を試してみたところ、実行時間は次のようになりました。
表 : 実行結果 問題 : Hint : 秒 ------+------+------- c1 : 22 : 3.95 d1 : 21 : 26.38 e1 : 24 : 2.41 h1 : 23 : 0.21 h2 : 24 : 0.71 実行環境 : ghci ver 8.8.4, Ubunts 18.04 (WSL), Intel Core i5-6200U 2.30GHz
このように、9 行 9 列盤の数独は単純なバックトラックで簡単に解くことができますが、問題によっては時間がかかります。今回の処理で時間がかかっているのは、数字を選択する処理です。空き場所に置くことができる数字を簡単に求めることができれば、もっと速くなるかもしれません。
●データ構造を工夫する
そこで、空き場所に置くことができる数字をデータとして持たせることにします。置くことができる数字は、各マスごとに持たせるのが自然な考え方です。必要なときに数字を直に求めることができますし、マスに数字を置いたならば、そのマスが属している縦、横、枠のマスに対して数字を削除すればいいわけです。
この方法では、縦と横で 16 個、枠で 4 個、合計で 20 個のマスを書き換えることになります。最近のパソコンはハイスペックなので、この程度であれば高速に動作すると思いますが、もっとクールな方法が 参考文献 [1] に書かれています。それは、「縦、横、枠のそれぞれについて、置くことができる数字をビットで管理する」という方法です。今回はこの方法を採用することにします。
ビットと数字の関係は次のように定義しましょう。
bit 9 8 7 6 5 4 3 2 1 0 => 数字に対応させる
---------------------
1 1 1 1 1 1 1 1 1 0 => 0x3fe : すべての数字を置くことができる
第 0 ビットはダミーとします。置くことができる数字は対応するビットをセットし、そうでなければビットをクリアします。
縦、横、枠の状態は、リスト xs, ys, gs で管理すろとしましょう。次の図を見てください。
左上隅のマス◎に注目してください。縦で使われている数字は 2, 6, 9 なので、xs の 0 番目の要素は 2 進数で表すと 0110111010 になります。横は 1, 3, 7, 8, 9 が使われているので、ys の 0 番目の要素は 0001110100 となります。枠 gs の 0 番目の要素は、2, 3, 8, 9 が使われているので 0011110010 となります。
マス◎に置くことができる数字は、この 3 つの状態でビットが立っている数字、つまり、ビットの論理積で求めることができます。
9876543210
----------
xs[0] => 0110111010
ys[0] => 0001110100
gs[0] => 0011110010
AND ----------
0000110000
マス◎に置くことができる数字は 4, 5 であることがわかります。
このように、縦、横、枠に分けて数字を管理するため、マスに置くことができる数字は、いちいち AND 演算しなければ求めることができません。ところが、マスに数字を置くときは縦、横、枠の該当するビットをクリアするだけで済ますことができます。
●盤面とフラグの定義
それではプログラムを作りましょう。最初にデータ構造を定義します。次のリストを見てください。
リスト : データ構造の定義 -- 盤面 type Board = [[Int]] -- フラグ data Flag = Flag [Int] [Int] [Int]
盤面の数字はビットの位置で表すことにします。空き場所は今までと同じく 0 で表します。Flag はフラグを表すデータ型で、3 つのリスト [Int] を格納します。先頭が縦、2 番目が横、3 番目が枠を表します。フラグの初期化は関数 initFlag で行います。
次は盤面の数字をビットの位置に変換する関数を定義します。
リスト : 盤面の変換 -- 数字をビットの位置に変換 numToBit :: Int -> Int numToBit 0 = 0 numToBit n = shiftL 1 n -- ビットの位置を数字に変換 bitToNum :: Int -> Int bitToNum 0 = 0 bitToNum n = popCount (n - 1) -- 盤面をビットボードに変換 toBitBoard :: Board -> Board toBitBoard board = map (\xs -> map (\x -> numToBit x) xs) board -- ビットボードを元に戻す fromBitBoard :: Board -> Board fromBitBoard board = map (\xs -> map (\x -> bitToNum x) xs) board
数字をビットの位置に変換するのは簡単で、shiftL で 1 を n ビット左シフトするだけです。ビット位置を数字に変換するのも簡単で、n から 1 を引いて 1 ビットの個数を popCount でカウントするだけです。あとは二重の map でリストの要素を変換するだけです。
●フラグの操作
次はフラグを書き換える関数を作りましょう。
リスト : フラグの書き換え
-- x, y から枠を求める
groupNum :: Int -> Int -> Int
groupNum x y = (y `div` 3) * 3 + x `div` 3
-- フラグを反転する
invFlag :: Flag -> Int -> Int -> Int -> Flag
invFlag (Flag xs ys gs) x y n =
Flag (invFlag' xs x n) (invFlag' ys y n) (invFlag' gs g n)
where
g = groupNum x y
invFlag' xs x n = substNth xs x $ (xs !! x) `xor` n
関数 groupNum は座標 (x, y) の枠の番号を求めます。invFlag は局所関数 invFlag' で縦、横、枠のフラグを反転します。invFlag' は簡単で、リストの x 番目の要素と n の排他的論理和 (xor) を求め、それを substNth で置き換えるだけです。
次はフラグを初期化する関数 initFlag を作ります。
リスト : データの読み込み
initFlag :: Board -> Flag
initFlag board = foldl (\a (x,y) -> let n = getNum board x y
in if n /= 0 then invFlag a x y n else a)
flag
[(x,y)| y <- [0..8], x <- [0..8]]
where flag = Flag (replicate 9 0x3fe)
(replicate 9 0x3fe)
(replicate 9 0x3fe)
Flag のリストはすべての数字のビットを 1 にセットした値 (0x3fe) に初期化します。次に、foldl で盤面の値 n を順番に取り出して、n が 0 でなければ infFlag でフラグの値を反転します。
次は空き場所に置くことができる数字を求める関数 placeNum を作ります。
リスト : 置くことができる数字を求める
-- ビットを分離
splitBit :: Int -> [Int]
splitBit 0 = []
splitBit n = m : splitBit (n `xor` m)
where m = (- n) .&. n
-- 置くことができる数字を求める
placeNum :: Flag -> Int -> Int -> [Int]
placeNum (Flag xs ys gs) x y =
splitBit $ xf .&. yf .&. gf
where xf = xs !! x
yf = ys !! y
gf = gs !! (groupNum x y)
関数 splitBit はビット 1 を分離してリストに格納して返します。この操作でビット 1 を取り出すことができる理由は、拙作のページ 整数の論理演算とビット操作 をお読みください。placeNum は縦、横、枠のフラグを取り出して、その論理積を求めます。これで置くことができる数字を求めることができます。あとはその値を splitBit に渡してリストに変換します。
●バックトラックによる解法
最後にバックトラックで解を求める関数 solver を作ります。
リスト : ナンバープレースの解法
solver :: Board -> [Board]
solver board = iter board' mkidx (initFlag board')
where board' = toBitBoard board
mkidx = [(x,y) | y <- [0..8], x <- [0..8], getNum board x y == 0]
iter board [] _ = return (fromBitBoard board)
iter board ((x, y):idx) flag = do
n <- placeNum flag x y
iter (putNum board x y n) idx (invFlag flag x y n)
最初に、toBitBoard で盤面の数字をビットの位置に変換します。次に、局所関数 iter を呼び出します。このとき、initFlag を呼び出してフラグを初期化します。あとは、placeNum で置くことができる数字を n にセットし、iter を再帰呼び出しするときに盤面とフラグを更新するだけです。解を見つけたら formBitBoard でビットの位置を数字に戻すことをお忘れなく。
●実行例 (2)
それでは、実行してみましょう。deepgreen さん が作成された ナンプレ問題集 より問題 9909-c1, 9909-d1, 9909-e1, 9909-h1, 9909-h2 を試してみたところ、実行時間は次のようになりました。
表 : 実行結果 (単位 : 秒) 問題 : Hint : (1) : (2) ------+------+-------+------- c1 : 22 : 3.95 : 2.09 d1 : 21 : 26.38 : 15.99 e1 : 24 : 2.41 : 1.36 h1 : 23 : 0.21 : 0.13 h2 : 24 : 0.71 : 0.48 実行環境 : ghci ver 8.8.4, Ubunts 18.04 (WSL), Intel Core i5-6200U 2.30GHz
実行時間は少し速くなりました。ここで、バックトラックする前に「確定サーチ」を行うと、実行時間はもっと速くなります。
●確定サーチ
それでは、確定サーチを行うプログラムを作りましょう。関数 initFlag でヒント数字を解析したら、空き場所に対して確定サーチを行います。確定サーチで注意する点は、確定できなかったマスでも、ほかのマスで数字が決定することで、確定できる場合があることです。したがって、一度だけ調べるのではなく、数字が確定したマスがある限り、何度でも調べなければいけません。プログラムは次のようになります。
リスト : 確定サーチ + バックトラック
solver' :: Board -> [Board]
solver' board =
if r
then [fromBitBoard b]
else iter b mkidx f
where board' = toBitBoard board
(b, f, r) = decideNum board' (initFlag board')
mkidx = [(x,y) | y <- [0..8], x <- [0..8], getNum b x y == 0]
iter board [] _ = return (fromBitBoard board)
iter board ((x, y):idx) flag = do
n <- placeNum flag x y
iter (putNum board x y n) idx (invFlag flag x y n)
-- 確定サーチ
decideNum :: Board -> Flag -> (Board, Flag, Bool)
decideNum board flag =
if null ss
then (board, flag, True)
else if a1 + a2 + a3 + a4 > 0
then decideNum b4 f4
else (b4, f4, False)
where ss = [(x, y) | y <- [0..8], x <- [0..8], getNum board x y == 0]
(b1, f1, a1) = decideCell board flag ss
(b2, f2, a2) = decideX b1 f1
(b3, f3, a3) = decideY b2 f2
(b4, f4, a4) = decideG b3 f3
関数 solver' は局所関数 iter を呼び出す前に確定サーチを行う関数 decideNum を呼び出します。decideNum の返り値は、盤面とフラグと真偽値です。True は解が見つかったことを表します。False の場合は iter を呼び出してバックトラックで解を探します。このとき、decideNum の返り値 (盤面とフラグ) を iter に渡します。
decideNum は最初に盤面から空き場所を求めて変数 ss にセットします。ss が空リストであれば解が見つかったので (board, flag, True) を返します。そうでなければ、4 つの関数を呼び出します。decideCell は置くことができる数字がひとつしかないマス (セル) を探します。decideX は縦方向の中で置くことができるマスがひとつしかない数字を探します。decideY が横方向の中で、decideG が枠の中で数字を決定できるマスを探します。
これらの関数は盤面とフラグと確定した場所の個数を返します。確定したマスが一つでもあれば、decideNum を再帰呼び出して確定サーチを繰り返します。確定したマスがひとつも無い場合は (b4, f4, False) を返します。簡単な問題であれば、確定サーチだけで解くことができるでしょう。また、難しい問題でも、確定サーチだけで解ける場合もあります。
●置ける数字がひとつしかないマスを探す
次は decideCell を作ります。
リスト : 置ける数字がひとつしかないマスを探す
decideCell :: Board -> Flag -> [(Int, Int)] -> (Board, Flag, Int)
decideCell board flag ss=
foldl (\(b, f, a) (x, y) -> let ns = placeNum f x y
n = head ns
in if length ns == 1
then (putNum b x y n, invFlag f x y n, a + 1)
else (b, f, a))
(board, flag, 0)
ss
decideCell は簡単です。foldl に渡すラムダ式の引数 (b, f, a) が盤面とフラグと確定した場所の個数を、(x, y) が空き場所を表します。placeNum で置くことができる数字を求め、それが一つしかなければ、(x, y) の位置は数字 n で確定することができます。putNum で盤面に num を書き込んで invFlag でフラグを反転し、確定した個数 a を +1 します。
●縦横枠で置くことができる数字を探す
次は縦、横、枠の確定サーチで共通で使用する関数を作ります。
リスト : 縦、横、枠の確定サーチで使用する関数
decideFrame' :: Board -> Flag -> Int -> [(Int,Int)] -> (Board, Flag, Int)
decideFrame' board flag n ss =
case xs of
[(x,y)] -> (putNum board x y n, invFlag flag x y n, 1)
_ -> (board, flag, 0)
where xs = foldl (\a (x, y) -> let ns = placeBitNum flag x y
in if ns .&. n /= 0
then (x,y):a else a)
[]
ss
decideFrame :: Board -> Flag -> [Int] -> [(Int,Int)] -> (Board, Flag, Int)
decideFrame board flag ns ss =
foldl (\(b, f, a) n ->
let (b', f', a') = decideFrame' b f n ss
in (b', f', a + a'))
(board, flag, 0)
ns
decideFrame は探索する枠組みの中で、確定できる数字と場所を求めます。引数 ns が未確定の数字のリスト、ss が空き場所のリストです。空き場所 ss の中で、数字 n を置くことができる場所が一つしかなければ、その空き場所を n に確定することができます。この処理を関数 decideFrame' で行います。
decideFrame' は foldl で数字 n を置くことができる空き場所を求めます。placeNumBit は置くことができる数字をビットで返す関数です。返り値 ns と n の論理積を求め、結果が 0 でなければ (x,y) に n を置くことができます。そして、置くことができる場所が一つだけしかない場合は、putNum で board に n をセットし、invFlag で flag を反転します。
次は縦、横、枠で確定できる数字を探す関数を作ります。
リスト : 数字を置ける場所を探す
-- 縦のチェック
decideX :: Board -> Flag -> (Board, Flag, Int)
decideX board flag@(Flag xs _ _) =
foldl (\(b, f, a) x ->
let ss = [(x, y) | y <- [0..8], getNum b x y == 0]
ns = splitBit $ xs !! x
(b', f', a') = decideFrame b f ns ss
in (b', f', a + a'))
(board, flag, 0)
[0..8]
-- 横のチェック
decideY :: Board -> Flag -> (Board, Flag, Int)
decideY board flag@(Flag _ ys _) =
foldl (\(b, f, a) y ->
let ss = [(x, y) | x <- [0..8], getNum b x y == 0]
ns = splitBit $ ys !! y
(b', f', a') = decideFrame b f ns ss
in (b', f', a + a'))
(board, flag, 0)
[0..8]
-- 枠のチェック
decideG :: Board -> Flag -> (Board, Flag, Int)
decideG board flag@(Flag _ _ gs) =
foldl (\(b, f, a) g ->
let x0 = (g `mod` 3) * 3
y0 = (g `div` 3) * 3
ss = [(x, y) | y <- [y0,y0+1,y0+2], x <- [x0,x0+1,x0+2], getNum b x y == 0]
ns = splitBit $ gs !! g
(b', f', a') = decideFrame b f ns ss
in (b', f', a + a'))
(board, flag, 0)
[0..8]
foldl に渡すラムダ式の引数 (b, f, a) は盤面、フラグ、確定した場所の個数を表します。もう一つの引数 x が列の番号、y が行の番号、g が枠の番号を表します。ラムダ式の let で空き場所を求めて ss にセットし、フラグから未確定の数字を求めて ns にセットします。あとは、b, f, ns, ss を decideFrame に渡して呼び出すだけです。
あとは特に難しいところはないでしょう。詳細は プログラムリスト１ をお読みください。
●実行例 (3)
それでは、実行してみましょう。deepgreen さん が作成された ナンプレ問題集 より問題 9909-c1, 9909-d1, 9909-e1, 9909-h1, 9909-h2 を試してみたところ、実行時間は次のようになりました。
表 : 実行結果 (単位 : 秒) 問題 : Hint : (1) : (2) : (3) ------+------+-------+-------+------- c1 : 22 : 3.95 : 2.09 : 0.17 d1 : 21 : 26.38 : 15.99 : 0.02 e1 : 24 : 2.41 : 1.36 : 0.03 h1 : 23 : 0.21 : 0.13 : 0.02 h2 : 24 : 0.71 : 0.48 : 0.03 実行環境 : ghci ver 8.8.4, Ubunts 18.04 (WSL), Intel Core i5-6200U 2.30GHz
インタプリタ ghci でも高速に解くことができました。確定サーチの効果はとても大きいことがわかります。ただし、どのような問題でも高速に解けるわけではなく、基本的な確定サーチだけでは高速化に限界があるようです。興味のある方はいろいろ試してみてください。
なお、バックトラックを使わないでナンプレを解く方法もあります。興味のある方は拙作のページ Scheme Programming パズルの解法 [6] [7] をお読みください。
●参考文献
- 松田晋, 『実践アルゴリズム戦略 解法のテクニック <第11回> バックトラックによる｢数独｣の解法』, C MAGAZINE 1993 年 3 月号, ソフトバンク
●プログラムリスト１
--
-- numplace.hs : ナンバープレースの解法
--
-- Copyright (C) 2013-2021 Makoto Hiroi
--
import Data.List
import Data.Bits
-- 盤面
type Board = [[Int]]
-- フラグ
data Flag = Flag [Int] [Int] [Int]
-- n 番目の要素を m に置き換える
substNth :: [a] -> Int -> a -> [a]
substNth [] _ _ = []
substNth (x:xs) 0 m = m : xs
substNth (x:xs) n m = x : substNth xs (n - 1) m
-- x, y から g を求める
groupNum :: Int -> Int -> Int
groupNum x y = (y `div` 3) * 3 + x `div` 3
-- フラグを反転する
invFlag :: Flag -> Int -> Int -> Int -> Flag
invFlag (Flag xs ys gs) x y n =
Flag (invFlag' xs x n) (invFlag' ys y n) (invFlag' gs g n)
where
g = groupNum x y
invFlag' xs x n = substNth xs x $ (xs !! x) `xor` n
-- 数字を書き込む
putNum :: Board -> Int -> Int -> Int -> Board
putNum board x y n =
substNth board y $ substNth (board !! y) x n
-- 数字を取り出す
getNum :: Board -> Int -> Int -> Int
getNum board x y = (board !! y) !! x
-- ビットを分離
splitBit :: Int -> [Int]
splitBit 0 = []
splitBit n = m : splitBit (n `xor` m)
where m = (- n) .&. n
-- 可能性のある数字を取り出す
placeNum :: Flag -> Int -> Int -> [Int]
placeNum (Flag xs ys gs) x y =
splitBit $ xf .&. yf .&. gf
where xf = xs !! x
yf = ys !! y
gf = gs !! (groupNum x y)
placeBitNum :: Flag -> Int -> Int -> Int
placeBitNum (Flag xs ys gs) x y =
xf .&. yf .&. gf
where xf = xs !! x
yf = ys !! y
gf = gs !! (groupNum x y)
-- フラグの初期化
initFlag :: Board -> Flag
initFlag board = foldl (\a (x,y) -> let n = getNum board x y
in if n /= 0 then invFlag a x y n else a)
flag
[(x,y)| y <- [0..8], x <- [0..8]]
where flag = Flag (replicate 9 0x3fe)
(replicate 9 0x3fe)
(replicate 9 0x3fe)
-- 数字をビットに変換
numToBit :: Int -> Int
numToBit 0 = 0
numToBit n = shiftL 1 n
-- ビットを数字に変換
bitToNum :: Int -> Int
bitToNum 0 = 0
bitToNum n = popCount (n - 1)
-- 盤面をビットボードに変換
toBitBoard :: Board -> Board
toBitBoard board =
map (\xs -> map (\x -> numToBit x) xs) board
-- ビットボードを元に戻る
fromBitBoard :: Board -> Board
fromBitBoard board =
map (\xs -> map (\x -> bitToNum x) xs) board
-- 解法
solver :: Board -> [Board]
solver board = iter board' mkidx (initFlag board')
where board' = toBitBoard board
mkidx = [(x,y) | y <- [0..8], x <- [0..8], getNum board x y == 0]
iter board [] _ = return (fromBitBoard board)
iter board ((x, y):idx) flag = do
n <- placeNum flag x y
iter (putNum board x y n) idx (invFlag flag x y n)
--
-- 確定サーチ
--
-- マスに候補が一つしかない
decideCell :: Board -> Flag -> [(Int, Int)] -> (Board, Flag, Int)
decideCell board flag ss=
foldl (\(b, f, a) (x, y) -> let ns = placeNum f x y
n = head ns
in if length ns == 1
then (putNum b x y n, invFlag f x y n, a + 1)
else (b, f, a))
(board, flag, 0)
ss
-- x, y, g のチェック
decideFrame' :: Board -> Flag -> Int -> [(Int,Int)] -> (Board, Flag, Int)
decideFrame' board flag n ss =
case xs of
[(x,y)] -> (putNum board x y n, invFlag flag x y n, 1)
_ -> (board, flag, 0)
where xs = foldl (\a (x, y) -> let ns = placeBitNum flag x y
in if ns .&. n /= 0
then (x,y):a else a)
[]
ss
decideFrame :: Board -> Flag -> [Int] -> [(Int,Int)] -> (Board, Flag, Int)
decideFrame board flag ns ss =
foldl (\(b, f, a) n ->
let (b', f', a') = decideFrame' b f n ss
in (b', f', a + a'))
(board, flag, 0)
ns
-- 縦のチェック
decideX :: Board -> Flag -> (Board, Flag, Int)
decideX board flag@(Flag xs _ _) =
foldl (\(b, f, a) x ->
let ss = [(x, y) | y <- [0..8], getNum b x y == 0]
ns = splitBit $ xs !! x
(b', f', a') = decideFrame b f ns ss
in (b', f', a + a'))
(board, flag, 0)
[0..8]
-- 横のチェック
decideY :: Board -> Flag -> (Board, Flag, Int)
decideY board flag@(Flag _ ys _) =
foldl (\(b, f, a) y ->
let ss = [(x, y) | x <- [0..8], getNum b x y == 0]
ns = splitBit $ ys !! y
(b', f', a') = decideFrame b f ns ss
in (b', f', a + a'))
(board, flag, 0)
[0..8]
-- 枠のチェック
decideG :: Board -> Flag -> (Board, Flag, Int)
decideG board flag@(Flag _ _ gs) =
foldl (\(b, f, a) g ->
let x0 = (g `mod` 3) * 3
y0 = (g `div` 3) * 3
ss = [(x, y) | y <- [y0,y0+1,y0+2], x <- [x0,x0+1,x0+2], getNum b x y == 0]
ns = splitBit $ gs !! g
(b', f', a') = decideFrame b f ns ss
in (b', f', a + a'))
(board, flag, 0)
[0..8]
decideNum :: Board -> Flag -> (Board, Flag, Bool)
decideNum board flag =
if null ss
then (board, flag, True)
else if a1 + a2 + a3 + a4 > 0
then decideNum b4 f4
else (b4, f4, False)
where ss = [(x, y) | y <- [0..8], x <- [0..8], getNum board x y == 0]
(b1, f1, a1) = decideCell board flag ss
(b2, f2, a2) = decideX b1 f1
(b3, f3, a3) = decideY b2 f2
(b4, f4, a4) = decideG b3 f3
-- 確定サーチ + バックトラック
solver' :: Board -> [Board]
solver' board =
if r
then [fromBitBoard b]
else iter b mkidx f
where board' = toBitBoard board
(b, f, r) = decideNum board' (initFlag board')
mkidx = [(x,y) | y <- [0..8], x <- [0..8], getNum b x y == 0]
iter board [] _ = return (fromBitBoard board)
iter board ((x, y):idx) flag = do
n <- placeNum flag x y
iter (putNum board x y n) idx (invFlag flag x y n)
改訂 2021 年 1 月 31 日