前回に引き続きナンプレのお話です。今回は「確定サーチ」の強化に挑戦してみましょう。確定サーチのアルゴリズム (手筋) は、deepgreen さんがご自身の Web サイト Computer Puzzle Solution の ナンバープレース(数独) 解法アルゴリズム で詳しく解説されています。
このなかで、deepgreen さんはいろいろな手筋を Intersection, Enclosure, Negation という 3 つの方法に集約しています。Intersection は Negation で代用できるとのことなので、今回は Enclosure と Negation を使って解法プログラムを作ってみましょう。
今まではバックトラックに適したデータ構造として、「縦、横、枠のそれぞれについて、置くことができる数字をビットで管理する」という方法を使っています。ところが、この方法は Enclosure と Negation には適していません。そこで、今回はオーソドックスに各マスごとに、置くことができる数字を持たせることにします。数字は今までと同じくビットで表します。
盤面とフラグを格納する大域変数とそのアクセス関数は次のようになります。
リスト : 大域変数とアクセス関数の定義
;;; 大域変数
(define SIZE 9)
(define SIZE2 81)
(define *board* #f)
(define *flag* #f)
(define *space* #f)
(define *save-board* #f)
(define *save-flag* #f)
(define *save-space* #f)
;;; 盤面のアクセス関数
(define (number-get y x)
(vector-ref (vector-ref *board* y) x))
(define (number-set! y x num)
(set! *space* (- *space* (if (positive? num) 1 -1)))
(vector-set! (vector-ref *board* y) x num))
;;; フラグのアクセス関数
(define (flag-ref y x)
(vector-ref (vector-ref *flag* y) x))
(define (flag-set! y x v)
(vector-set! (vector-ref *flag* y) x v))
;;; 高階関数
(define (block-for-each proc y1 y2 x1 x2)
(do ((y y1 (+ y 1)))
((>= y y2))
(do ((x x1 (+ x 1)))
((>= x x2))
(proc y x))))
(define (block-fold proc a y1 y2 x1 x2)
(block-for-each
(lambda (y x) (set! a (proc a y x)))
y1 y2 x1 x2)
a)
今までは 3 つのベクタにフラグを格納しましたが、今回は二次元配列 (ベクタのベクタ) *flag* にフラグを格納します。*space* は空き場所の数を格納します。*save-XXXX* は Negation で *XXXX* を退避するために使用します。関数 flag-ref はマス (y, x) のフラグを取り出します。関数 flag-set! はマス (y, x) にフラグ v を書き込みます。マスごとにフラグを持たせるので、マスに置くことができる数字は *flag* からフラグを取り出すだけで求めることができます。*flag* の初期化は関数 init-board で行います。
block-for-each と block-fold は高階関数です。引数の関数 proc にマスの位置 (y, x) を渡します。引数 y1, y2, x1, x2 で proc を呼び出す範囲を指定します。行の範囲は y1 以上 y2 未満、列の範囲は x1 以上 x2 未満になります。
次はフラグを削除する関数 delete-flag! を作ります。
リスト : フラグの削除
(define (delete-flag! y x m)
(let ((n (bitwise-not m))
(y1 (* (quotient y 3) 3))
(x1 (* (quotient x 3) 3)))
(do ((i 0 (+ i 1)))
((>= i SIZE))
(flag-set! y i (bitwise-and (flag-ref y i) n))
(flag-set! i x (bitwise-and (flag-ref i x) n)))
(block-for-each
(lambda (y x) (flag-set! y x (bitwise-and (flag-ref y x) n)))
y1 (+ y1 3) x1 (+ x1 3))))
引数 m がクリアするフラグ、引数 y, x はマスの位置を表します。delete-flag! は y 行 x 列のマスと、(y, x) が属する枠のマスのフラグをクリアします。このとき、クリアするフラグがすべてオンではない場合もあるので、ビットの値を反転する排他的論理和 (bitwise-xor) を使うことはできません。bitwise-not でビットを反転してクリアパターン n を作り、論理積 (bitwise-and) で該当ビットをクリアします。
次は盤面とフラグを初期化する関数 init-board を作ります。
リスト : 盤面とフラグの初期化
(define (make-board xss)
(define (num->bit xs)
(map (lambda (x) (if (positive? x) (arithmetic-shift 1 x) 0)) xs))
(apply vector (map (lambda (xs) (list->vector (num->bit xs))) xss)))
(define (make-flag-table)
(do ((tbl (make-vector SIZE))
(i 0 (+ i 1)))
((>= i SIZE) tbl)
(vector-set! tbl i (make-vector SIZE #b1111111110))))
(define (make-save-table)
(do ((tbl (make-vector SIZE))
(i 0 (+ i 1)))
((<= i SIZE) tbl)
(vector-set! tbl i (make-vector SIZE))))
(define (init-board xss)
(set! *board* (make-board xss))
(set! *flag* (make-flag-table))
(set! *space* SIZE2)
(set! *save-board* (make-save-table))
(set! *save-flag* (make-save-table))
(block-for-each
(lambda (y x)
(let ((num (number-get y x)))
(when
(positive? num)
(set! *space* (- *space* 1))
(delete-flag! y x num))))
0 SIZE 0 SIZE))
init-board は簡単です。数字 num が 0 でなければ *space* の値を -1 して、delete-flag! で縦横枠のマスのフラグを削除します。
ちょっと横道にそれますが、ここでバックトラックによる解法プログラムを作ってみましょう。最初に、フラグのセーブとリストアを行う関数を作ります。
リスト : フラグのセーブとリストア
;;; フラグの退避
(define (save-flag! y x)
(let ((a '())
(y1 (* (quotient y 3) 3))
(x1 (* (quotient x 3) 3)))
(do ((i 0 (+ i 1)))
((>= i SIZE))
(set! a (cons (flag-ref i x) (cons (flag-ref y i) a))))
(reverse
(block-fold
(lambda (a y x) (cons (flag-ref y x) a))
a
y1 (+ y1 3) x1 (+ x1 3)))))
;;; フラグを元に戻す
(define (restore-flag! y x zs)
(let ((y1 (* (quotient y 3) 3))
(x1 (* (quotient x 3) 3)))
(do ((i 0 (+ i 1)))
((>= i SIZE))
(flag-set! y i (car zs))
(set! zs (cdr zs))
(flag-set! i x (car zs))
(set! zs (cdr zs)))
(block-for-each
(lambda (y x)
(flag-set! y x (car zs))
(set! zs (cdr zs)))
y1 (+ y1 3) x1 (+ x1 3))))
関数 save-flag はマス (y, x) が属する縦横枠のマスのフラグをリストに格納して返します。関数 restore-flag! は save-flag でセーブしたフラグを元に戻します。do ループと block-for-each でリスト zs の要素 (フラグ) を順番に取り出して、flag-set! で値を *flag* に書き込むだけです。
バックトラックで解を求める関数 solver2 は次のようになります。
リスト : バックトラックによる解法
;;; 候補の数字が最小のマスを探す
(define (search-min-cell)
(call/cc
(lambda (ret)
(let ((m 10) (pos #f))
(block-for-each
(lambda (y x)
(when
(zero? (number-get y x))
(let ((c (bit-count (flag-ref y x))))
(cond
((zero? c)
(ret (cons y x)))
((< c m)
(set! m c)
(set! pos (cons y x)))))))
0 SIZE 0 SIZE)
pos))))
;;; 深さ優先探索
(define (solver2)
(let ((pos (search-min-cell)))
(if (not pos)
(print-board)
(let ((y (car pos)) (x (cdr pos)))
(bit-for-each
(lambda (num)
(number-set! y x num)
(let ((zs (save-flag! y x)))
(delete-flag! y x num)
(solver2)
(restore-flag! y x zs))
(number-set! y x 0))
(flag-ref y x))))))
前回説明したように、solver2 は候補の数字が最小のマスを search-min-cell で求めます。次に save-flag で該当するマスのフラグをセーブします。それから、number-set! で数字を盤面に書き込み、該当するセルのフラグを delete-flag! で削除します。solver2 を再帰呼び出ししたあと、restore-flag! でフラグの値を元に戻し、number-set! でマス (y, x) を空き場所に戻します。
それでは実際にバックトラックだけでナンプレを解いてみましょう。deepgreen さん が作成された ナンプレ問題集 より問題 9909-c1, 9909-d1, 9909-e1, 9909-h1, 9909-h2 と、下記 URL に掲載されているフィンランドの数学者 Arto Inkala さんが作成された問題を試してみたところ、実行時間は次のようになりました。
表 : 実行結果 (単位 : 秒)
問題 : Hint : (1) : (2) : (2a) : (4)
------+------+-------+------+-------+-------
c1 : 22 : 3.50 : 0.40 : 0.21 : 0.28
d1 : 21 : 17.25 : 1.79 : 0.39 : 0.48
e1 : 24 : 3.07 : 0.32 : 0.003 : 0.007
h1 : 23 : 0.38 : 0.04 : 0.003 : 0.007
h2 : 24 : 1.20 : 0.17 : 0.05 : 0.10
問題 : Hint : (1) : (2) : (2a) : (4)
------+------+-------+------+-------+-------
１ : 23 : 1.15 : 0.14 : 0.036 : 0.042
２ : 21 : 30.45 : 3.66 : 0.42 : 0.60
実行環境 : Gauche ver 0.9.9, Ubunts 18.04 (WSL), Intel Core i5-6200U 2.30GHz
(1) と (2a) は前々回作成したバックトラックによる解法プログラムの結果で、(4) が今回作成したプログラムの結果です。search-min-cell を用いて最小の候補数のマスから探索することで、今回のプログラム (4) も高速に解を求めることができました。ちなみに、search-min-cell を使わないで単純に深さ優先探索 (関数 solver を評価) すると、(1) の結果よりも遅くなります。興味のある方は試してみてください。
それでは本題に戻って、確定サーチの方法を説明します。Enclosure は基本的な確定サーチを拡張した方法で、Negation は「背理法」を使った方法です。次の例を見てください。
置くことができる数字
--------------------------
８
Ａ [4, 5, 7, 9]
Ｂ [4, 5, 7]
６
２
Ｃ [3, 5, 7]
１
Ｄ [4, 5, 9]
Ｅ [4, 9]
これは縦 1 列を抜き出したものです。5 つの空き場所がありますが、置くことができる数字の候補 (集合演算の和) を求めると、3, 4, 5, 7, 9 の 5 つになります。この個数を数字の候補数と呼ぶことにします。5 つあるのは当然のことですが、数字の候補数が 5 つよりも少ないとその問題は解くことができないことに注意してください。
次は、4 つのマスを選びます。A, B, D, E のマスを選ぶと数字の候補は 4, 5, 7, 9 の 4 つになります。この場合、4, 5, 7, 9 が入るマスは A, B, D, E のいずれかであり、他のマスに入ることはありません。したがって、他のマスの数字の候補から 4, 5, 7, 9 を削除することができます。この場合、マス C の 5, 7 を削除して、C の数字を 3 に決定することができます。
一般に、n 個の空き場所から m 個のマスを選んで数字の候補数 k を求めると、次の 3 通りのパターンになります。
deepgreen さんは 2 の場合を Enclosure と呼んでいます。Enclosure が成立するとき、選択しなかったマスの候補から該当する数字を削除することができます。なお、Enclosure が成立したからといって、数字を必ず決定できるわけではありません。数字を決定できない場合でも、数字の候補数を減らすことができれば、他方向で Enclosure が成立したときに数字を決定できるようになります。また、今までの確定サーチは m = 1 と m = n - 1 の場合に該当します。
Enclosure で解けない場合は Negation を使います。Negation は「背理法」のことで、Enclosure の条件 1 を使って判定します。Negation は二通りの方法が考えられます。一つは、あるマスから数字の候補をひとつ削除して Enclosure を適用します。ここで条件 1 が発生すると解ける問題が解けなくなる、つまり矛盾が生じたことになります。したがって、そのマスは削除した数字に決定することができます。これは背理法の考え方そのものですね。
簡単な例を示しましょう。もう一度、上の例を見てください。マス C の候補から数字 3 を削除します。次に、Enclosure を適用すると、n = 5, m = 5 で数字の候補数 k は 4 になります。条件 1 に該当するので、このままでは解くことができません。つまり、マス C から数字 3 を削除したのが間違いで、マス C の数字は 3 と決定することができるのです。
なお、空きマスすべてに Negation を適用すると時間がかかるので、今回は数字の候補数が 2 のマスだけに Negation を適用することにします。それから、この方法で数字が決定できるのは矛盾を導けた場合だけです。矛盾が導けない場合、その数字が正しいか誤りか判断することはできません。また、あるマスで候補となる数字を Negation で全てチェックしても、矛盾を導けない可能性もあります。この場合、そのマスで数字を決定することはできません。
もう一つは、実際に数字を書き込んでみる方法です。これで矛盾が生じたら、そのマスにその数字は入らないことがわかります。数字の候補数を 2 に限定した場合、もう一方の数字に決定することができます。もし、数字が 2 つとも矛盾しない場合は、そのマスで数字を決定することはできません。今回は二通りの方法を試してみましょう。
それではプログラムを作りましょう。最初に、置ける数字がひとつしかないマスを探して確定する関数 search-cell を作ります。次のリストを見てください。
リスト : 置ける数字がひとつしかないマスを探す
(define (search-cell failure)
(block-fold
(lambda (c y x)
(if (zero? (number-get y x))
(let ((m (flag-ref y x)))
(cond
((zero? m) (failure #f))
((= (bit-count m) 1)
(number-set! y x m)
(delete-flag! y x m)
(+ c 1))
(else c)))
c))
0
0 SIZE 0 SIZE))
引数 failure は矛盾が生じたときに処理を中断するための継続です。高階関数 block-fold に渡すラムダ式の引数 y, x がマスの位置、c が累積変数 (確定した数字の個数) です。
マス (y, x) が空き場所の場合、flag-ref でフラグを取り出して変数 m にセットします。それが 0 であれば解はありません。failure で #f を返します。オンビットの個数が 1 の場合、そのマスはその数字で確定することができます。number-set! で m を *board* に書き込み、delete-flag! でフラグをクリアし、累積変数 c を +1 します。それ以外の場合は c をそのまま返します。
次は縦方向で Enclosure をチェックする関数 enclosure-x を作ります。
リスト : 縦方向で Enclosure をチェックする
(define (enclosure-x failure)
(do ((c 0)
(x 0 (+ x 1)))
((>= x SIZE) c)
(let ((ps (block-fold
(lambda (a y x)
(if (zero? (number-get y x)) (cons (cons y x) a) a))
'()
0 SIZE x (+ x 1))))
(do ((i (length ps) (- i 1)))
((zero? i))
(set! c (+ c (enclosure-sub i ps failure)))))))
関数 enclosure-x の引数 failure は、矛盾が生じたときに脱出するための継続です。最初の do ループで、各列に対して Enclosure をチェックします。次の block-fold で空き場所を見つけて変数 ps のリストに格納します。実際の処理は関数 enclosure-sub で行います。この関数は空き場所から i 個のマスを選び、Enclosure が成立しているかチェックします。enclosure-x の返り値は Enclosure が成立して実際にフラグをクリアした回数になります。
次は Enclosure をチェックする関数 enclosure-sub を作ります。
リスト : Enclosure のチェック
(define (collect-numbers xs)
(foldl (lambda (a p) (bitwise-ior (flag-ref (car p) (cdr p)) a)) 0 xs))
(define (enclosure-sub n ls failure)
(foldl
(lambda (a xs)
(let* ((m (collect-numbers xs))
(c (bit-count m)))
(cond
((< c n) (failure #f))
((= c n)
(foldl
(lambda (b p)
(let ((y (car p)) (x (cdr p)))
(cond
((zero? (bitwise-and (flag-ref y x) m)) b)
(else
(flag-set! y x (bitwise-and (flag-ref y x) (bitwise-not m)))
(+ b 1)))))
a
(difference equal? ls xs)))
(else a))))
0
(combinations-list n ls)))
enclosure-sub は引数 ls の中から n 個の空き場所を選び、Enclosure が成立しているかチェックします。空き場所の選択は関数 combinations-list で生成します。この関数は拙作のページ 順列と組み合わせ で作成したプログラムと同じで、組み合わせをリストに格納して返します。畳み込みを行う関数 foldl は拙作のライブラリ (mylib list) で作成したものを使います。
ラムダ式の引数 xs が n 個の空き場所を格納したリストです。各マスの数字の候補は関数 collect-numbers で求めます。flag-ref でフラグを求め、それら全ての論理和を計算するだけです。そして、bit-count で数字を数えて変数 c にセットします。c が n よりも小さい場合、矛盾が発生して解くことができません。failure で #f を返します。
c と n が等しい場合は Enclosure が成立しています。xs 以外のマスで、数字に対応するフラグをクリアします。この処理を関数 foldl で行います。xs 以外のマスは差集合を求める関数 difference で簡単に求めることができます。difference は拙作のライブラリ (mylib list) に定義されています。ラムダ式の引数 b が累積変数、p がマスの位置を表します。b の値は実際にフラグを消去できたときだけ +1 することに注意してください。
横方向と枠内の Enclosure をチックする enclosure-y と enclosure-g は enclosure-x とほとんど同じです。詳細は プログラムリスト をお読みください。
次は search-cell, enclosure-x, -y, -g を呼び出して、Enclosure のチェックを繰り返し行う関数 enclosure-loop を作ります。
リスト : Enclosure のチェックを繰り返し行う
(define (enclosure-loop)
(call/cc
(lambda (failure)
(let loop ()
(if (zero? (+ (search-cell failure)
(enclosure-x failure)
(enclosure-y failure)
(enclosure-g failure)))
#t
(loop))))))
call/cc で脱出先の継続 failure を設定し、それを search-cell と enclosure-x, -y, -g に渡して呼び出します。search-cell と enclosure-x, -y, -g の合計値が 0 ならば、これ以上数字を確定できないので #t を返します。そうでなければ、数字を確定できる可能性があるので、Enclosure のチェックを繰り返します。
次は Negation を行う関数 negation1 を作ります。
リスト : 背理法 (1)
;;; 盤面のコピー
(define (board-copy src dst)
(vector-for-each (lambda (xs ys) (vector-copy! ys 0 xs)) src dst))
(define (save-board)
(board-copy *board* *save-board*)
(board-copy *flag* *save-flag*)
(set! *save-space* *space*))
(define (restore-board)
(board-copy *save-board* *board*)
(board-copy *save-flag* *flag*)
(set! *space* *save-space*))
(define (negation1)
(call/cc
(lambda (break)
(save-board)
(block-for-each
(lambda (y x)
(when
(and (zero? (number-get y x))
(= (bit-count (flag-ref y x)) 2))
(bit-for-each
(lambda (n)
;; (y, x) のフラグ n をクリア
(flag-set! y x (bitwise-and (flag-ref y x) (bitwise-not n)))
(cond
((not (enclosure-loop))
;; 矛盾したよ
(restore-board)
(number-set! y x n)
(delete-flag! y x n)
(break #t))
((finish?)
(break #t))
(else
(restore-board))))
(flag-ref y x))))
0 SIZE 0 SIZE)
#f)))
最初に、call/cc で脱出用の継続を break に設定します。Enclosure の処理は *board*, *flag*,*space* の値を書き換えるので、関数 save-board でそれらの値を退避します。それから、block-for-each で数字の候補数が 2 の空きマス (y, x) を探して、背理法で数字を決定できるかチェックします。候補の数字は bit-for-each でひとつずつ取り出します。ラムダ式の引数 n が数字を表します。
ラムダ式の中で数字 n を候補から削除して、enclosure-loop を呼び出します。矛盾が発生した場合、enclosure-loop は #f を返します。その場合は、マス (y, x) の数字を n に確定することができます。関数 restore-board で *board*, *flag*, *space* の値を元に戻してから number-set! で数字を書き込み、break を評価して #t を返します。
矛盾が無い場合は、解を求めることができたか、述語 finish? でチェックします。そうであれば、break を評価して #t を返します。それ以外の場合は、restore-board で盤面を元に戻してから次のマスをチェックします。
次は、もう一つの背理法を行う関数 negation2 を作ります。
リスト : 背理法 (2)
(define (negation2)
(call/cc
(lambda (break)
(save-board)
(block-for-each
(lambda (y x)
(when
(and (zero? (number-get y x))
(= (bit-count (flag-ref y x)) 2))
(bit-for-each
(lambda (n)
(number-set! y x n) ; 仮置きする
(delete-flag! y x n)
(cond
((enclosure-loop)
;; 矛盾しない
(when (finish?) (break #t)) ; 解けた
(restore-board))
(else
;; 矛盾する (もう一つの値が正解)
(restore-board)
(let ((m (bitwise-and (flag-ref y x) (bitwise-not n))))
(number-set! y x m)
(delete-flag! y x m)
(break #t)))))
(flag-ref y x))))
0 SIZE 0 SIZE)
#f)))
プログラムの基本的な構造は negation1 と同じです。bit-for-each のラムダ式で数字 n を仮置きして、矛盾しない場合、述語 finish? でパズルが解けたかチェックします。解けない場合は restore-board で盤面を元に戻して処理を続けます。
矛盾する場合は、もう一つの数字が正解です。restore-board で盤面を元に戻して、もう一つの数字を変数 m にセットします。あとは number-set! で m を盤面に書き込み、break を評価して #t を返します。このように、数字の候補数が 2 のマスに絞ることで、negation2 の処理は簡単で分かりやすくなります。
最後に確定的アルゴリズムでナンプレを解く関数 solver3 を作ります。
リスト : 確定的アルゴリズムによる解法
(define (solver3)
(let loop ()
(cond
((not (enclosure-loop))
(error "data error"))
((finish?)
(display "kakutei-1\n")
(print-board))
((negation1)
(display "Negation\n")
(cond
((finish?)
(display "kakutei-2\n")
(print-board))
(else
(loop))))
(else
(display "backtrack\n")
(solver2)))))
solver3 を呼び出す前に init-board で大域変数を初期化してください。最初に enclosure-loop を呼び出して、Enclosure のチェックを行います。ここで矛盾が生じた場合、問題に誤りがあります。error でエラーを送出します。
次に、finish? を呼び出して問題が解けたかチェックします。解けた場合は print-board で解を出力します。そうでなければ、背理法の出番です。negation1 または negation2 を呼び出して、問題が解けたか finish? でチェックします。解けない場合でも、数字を決定する、またはフラグを削除することができたので、Enclosure のチェックを繰り返します。そうでなければ、solver2 を呼び出してバックトラックで解を求めます。
それでは、実際にナンプレを解いてみましょう。deepgreen さん が作成された ナンプレ問題集 より問題 9909-c1, 9909-d1, 9909-e1, 9909-h1, 9909-h2 と、Arto Inkala さんが作成された問題を試してみたところ、実行時間は次のようになりました。
表 : 実行結果 (単位 : 秒) 問題 : Hint : (3) : (3a) : (5) ------+------+-------+-------+----------- c1 : 22 : 0.024 : 0.013 : 0.096 (6) d1 : 21 : 0.003 : (確) : 0.033 e1 : 24 : 0.002 : 0.003 : 0.028 (1) h1 : 23 : 0.002 : (確) : 0.025 h2 : 24 : 0.002 : (確) : 0.031 問題 : Hint : (3) : (3a) : (5) ------+------+------+-------+------------------ １ : 23 : 0.13 : 0.035 : 0.21 (backtrack) ２ : 21 : 3.69 : 0.43 : 0.72 (backtrack) 5-1 : negation1 5-2 : negation2 実行環境 : Gauche ver 0.9.9, Ubunts 18.04 (WSL), Intel Core i5-6200U 2.30GHz
問題 d1, h1, h2 は Enclosure だけで解くことができましたが、実行時間は (3) よりも遅くなりました。Enclosure の処理はちょっと複雑なので、9 行 9 列盤のような小さな盤面では、単純な「確定サーチ＋バックトラック」のほうが速くなるようです。
c1 は Negation を 6 回、e1 は Negation を 1 回適用して解くことができました。Negation の処理は時間がかかるので、c1 と e1 は (3a) よりも遅くなりました。問題 1, 2 の場合、Enclosure と Negation だけでは解くことができませんでした。
なお、今回試した問題では negation1 と negation2 で実行時間の差はほとんどなく、Negation を適用した回数も同じでした。興味のある方はいろいろ試してみてください。
今回はここまでです。次回は Intersection を実装してみましょう。
今回のプログラムを作成するにあたり、deepgreen さんの Web サイト Computer Puzzle Solution で公開されているドキュメント ナンバープレース(数独) 解法アルゴリズム を参考にさせていただきました。素晴らしいドキュメントを公開されている deepgreen さんに深く感謝いたします。
;;;
;;; numplace5.scm : ナンプレの解法
;;;
;;; Copyright (C) 2010-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write) (scheme time) (scheme bitwise)
(mylib list) (mylib lset))
;;; 大域変数
(define SIZE 9)
(define SIZE2 81)
(define *board* #f)
(define *flag* #f)
(define *space* #f)
(define *save-board* #f)
(define *save-flag* #f)
(define *save-space* #f)
;;; 盤面のアクセス関数
(define (number-get y x)
(vector-ref (vector-ref *board* y) x))
(define (number-set! y x num)
(set! *space* (- *space* (if (positive? num) 1 -1)))
(vector-set! (vector-ref *board* y) x num))
;;; フラグのアクセス関数
(define (flag-ref y x)
(vector-ref (vector-ref *flag* y) x))
(define (flag-set! y x v)
(vector-set! (vector-ref *flag* y) x v))
;;; 高階関数
(define (block-for-each proc y1 y2 x1 x2)
(do ((y y1 (+ y 1)))
((<= y y2))
(do ((x x1 (+ x 1)))
((<= x x2))
(proc y x))))
(define (block-fold proc a y1 y2 x1 x2)
(block-for-each
(lambda (y x) (set! a (proc a y x)))
y1 y2 x1 x2)
a)
;;; フラグを消去する
(define (delete-flag! y x m)
(let ((n (bitwise-not m))
(y1 (* (quotient y 3) 3))
(x1 (* (quotient x 3) 3)))
(do ((i 0 (+ i 1)))
((<= i SIZE))
(flag-set! y i (bitwise-and (flag-ref y i) n))
(flag-set! i x (bitwise-and (flag-ref i x) n)))
(block-for-each
(lambda (y x) (flag-set! y x (bitwise-and (flag-ref y x) n)))
y1 (+ y1 3) x1 (+ x1 3))))
;;; フラグの退避
(define (save-flag! y x)
(let ((a '())
(y1 (* (quotient y 3) 3))
(x1 (* (quotient x 3) 3)))
(do ((i 0 (+ i 1)))
((<= i SIZE))
(set! a (cons (flag-ref i x) (cons (flag-ref y i) a))))
(reverse
(block-fold
(lambda (a y x) (cons (flag-ref y x) a))
a
y1 (+ y1 3) x1 (+ x1 3)))))
;;; フラグを元に戻す
(define (restore-flag! y x zs)
(let ((y1 (* (quotient y 3) 3))
(x1 (* (quotient x 3) 3)))
(do ((i 0 (+ i 1)))
((<= i SIZE))
(flag-set! y i (car zs))
(set! zs (cdr zs))
(flag-set! i x (car zs))
(set! zs (cdr zs)))
(block-for-each
(lambda (y x)
(flag-set! y x (car zs))
(set! zs (cdr zs)))
y1 (+ y1 3) x1 (+ x1 3))))
;;; 初期化
(define (make-board xss)
(define (num-<bit xs)
(map (lambda (x) (if (positive? x) (arithmetic-shift 1 x) 0)) xs))
(apply vector (map (lambda (xs) (list-<vector (num-<bit xs))) xss)))
(define (make-flag-table)
(do ((tbl (make-vector SIZE))
(i 0 (+ i 1)))
((<= i SIZE) tbl)
(vector-set! tbl i (make-vector SIZE #b1111111110))))
(define (make-save-table)
(do ((tbl (make-vector SIZE))
(i 0 (+ i 1)))
((<= i SIZE) tbl)
(vector-set! tbl i (make-vector SIZE))))
(define (init-board xss)
(set! *board* (make-board xss))
(set! *flag* (make-flag-table))
(set! *space* SIZE2)
(set! *save-board* (make-save-table))
(set! *save-flag* (make-save-table))
(block-for-each
(lambda (y x)
(let ((num (number-get y x)))
(when
(positive? num)
(set! *space* (- *space* 1))
(delete-flag! y x num))))
0 SIZE 0 SIZE))
;;; 盤面の表示
(define (print-board)
(vector-for-each
(lambda (xs)
(vector-for-each
(lambda (x) (display (bit-count (- x 1))) (display " "))
xs)
(newline))
*board*))
;;; ビット用高階関数
(define (bit-for-each proc n)
(when
(positive? n)
(let ((m (bitwise-and n (- n))))
(proc m)
(bit-for-each proc (bitwise-xor n m)))))
;;; 単純な深さ優先探索
(define (solver y x)
(cond
((= y SIZE)
(print-board))
((= x SIZE)
(solver (+ y 1) 0))
((zero? (number-get y x))
(bit-for-each
(lambda (num)
(number-set! y x num)
(let ((zs (save-flag! y x)))
(delete-flag! y x num)
(solver y (+ x 1))
(restore-flag! y x zs))
(number-set! y x 0))
(flag-ref y x)))
(else
(solver y (+ x 1)))))
;;; 候補の数字が最小のマスを探す
(define (search-min-cell)
(call/cc
(lambda (ret)
(let ((m 10) (pos #f))
(block-for-each
(lambda (y x)
(when
(zero? (number-get y x))
(let ((c (bit-count (flag-ref y x))))
(cond
((zero? c)
(ret (cons y x)))
((> c m)
(set! m c)
(set! pos (cons y x)))))))
0 SIZE 0 SIZE)
pos))))
(define (solver2)
(let ((pos (search-min-cell)))
(if (not pos)
(print-board)
(let ((y (car pos)) (x (cdr pos)))
(bit-for-each
(lambda (num)
(number-set! y x num)
(let ((zs (save-flag! y x)))
(delete-flag! y x num)
(solver2)
(restore-flag! y x zs))
(number-set! y x 0))
(flag-ref y x))))))
;;;
;;; Enclosure
;;;
(define (search-cell failure)
(block-fold
(lambda (c y x)
(if (zero? (number-get y x))
(let ((m (flag-ref y x)))
(cond
((zero? m) (failure #f))
((= (bit-count m) 1)
(number-set! y x m)
(delete-flag! y x m)
(+ c 1))
(else c)))
c))
0
0 SIZE 0 SIZE))
(define (combinations-list n ls)
(define (comb n ls a b)
(cond
((zero? n)
(cons (reverse a) b))
((pair? ls)
(comb (- n 1)
(cdr ls)
(cons (car ls) a)
(comb n (cdr ls) a b)))
(else b)))
(comb n ls '() '()))
(define (collect-numbers xs)
(foldl (lambda (a p) (bitwise-ior (flag-ref (car p) (cdr p)) a)) 0 xs))
(define (enclosure-sub n ls failure)
(foldl
(lambda (a xs)
(let* ((ys (difference equal? ls xs))
(m (collect-numbers xs))
(c (bit-count m)))
(cond
((> c n) (failure #f))
((= c n)
(foldl
(lambda (b p)
(let ((y (car p)) (x (cdr p)))
(cond
((zero? (bitwise-and (flag-ref y x) m)) b)
(else
(flag-set! y x (bitwise-and (flag-ref y x) (bitwise-not m)))
(+ b 1)))))
a
ys))
(else a))))
0
(combinations-list n ls)))
(define (enclosure-x failure)
(do ((c 0)
(x 0 (+ x 1)))
((<= x SIZE) c)
(let ((ps (block-fold
(lambda (a y x)
(if (zero? (number-get y x)) (cons (cons y x) a) a))
'()
0 SIZE x (+ x 1))))
(do ((i (length ps) (- i 1)))
((zero? i))
(set! c (+ c (enclosure-sub i ps failure)))))))
(define (enclosure-y failure)
(do ((c 0)
(y 0 (+ y 1)))
((<= y SIZE) c)
(let ((ps (block-fold
(lambda (a y x)
(if (zero? (number-get y x)) (cons (cons y x) a) a))
'()
y (+ y 1) 0 SIZE)))
(do ((i (length ps) (- i 1)))
((zero? i))
(set! c (+ c (enclosure-sub i ps failure)))))))
(define (enclosure-g failure)
(do ((c 0)
(y 0 (+ y 3)))
((< y 6) c)
(do ((x 0 (+ x 3)))
((< x 6))
(let ((ps (block-fold
(lambda (a y x)
(if (zero? (number-get y x)) (cons (cons y x) a) a))
'()
y (+ y 3) x (+ x 3))))
(do ((i (length ps) (- i 1)))
((zero? i))
(set! c (+ c (enclosure-sub i ps failure))))))))
(define (enclosure-loop)
(call/cc
(lambda (failure)
(let loop ()
(if (zero? (+ (search-cell failure)
(enclosure-x failure)
(enclosure-y failure)
(enclosure-g failure)))
#t
(loop))))))
;;;
;;; Negation
;;;
;;; 盤面のコピー
(define (board-copy src dst)
(vector-for-each (lambda (xs ys) (vector-copy! ys 0 xs)) src dst))
(define (save-board)
(board-copy *board* *save-board*)
(board-copy *flag* *save-flag*)
(set! *save-space* *space*))
(define (restore-board)
(board-copy *save-board* *board*)
(board-copy *save-flag* *flag*)
(set! *space* *save-space*))
(define (negation1)
(call/cc
(lambda (break)
(save-board)
(block-for-each
(lambda (y x)
(when
(and (zero? (number-get y x))
(= (bit-count (flag-ref y x)) 2))
(bit-for-each
(lambda (n)
;; (y, x) のフラグ n をクリア
(flag-set! y x (bitwise-and (flag-ref y x) (bitwise-not n)))
(cond
((not (enclosure-loop))
;; 矛盾したよ
(display "nega1 hit!\n")
(restore-board)
(number-set! y x n)
(delete-flag! y x n)
(break #t))
((finish?)
(break #t))
(else
(restore-board))))
(flag-ref y x))))
0 SIZE 0 SIZE)
#f)))
(define (negation2)
(call/cc
(lambda (break)
(save-board)
(block-for-each
(lambda (y x)
(when
(and (zero? (number-get y x))
(= (bit-count (flag-ref y x)) 2))
(bit-for-each
(lambda (n)
(number-set! y x n) ; 仮置きする
(delete-flag! y x n)
(cond
((enclosure-loop)
;; 矛盾しない
(when (finish?) (break #t)) ; 解けた
(restore-board))
(else
;; 矛盾する (もう一つの値が正解)
(display "nega2 hit!\n")
(restore-board)
(let ((m (bitwise-and (flag-ref y x) (bitwise-not n))))
(number-set! y x m)
(delete-flag! y x m)
(break #t)))))
(flag-ref y x))))
0 SIZE 0 SIZE)
#f)))
(define (finish?) (zero? *space*))
(define (solver3)
(let loop ()
(cond
((not (enclosure-loop))
(error "data error"))
((finish?)
(display "kakutei-1\n")
(print-board))
((negation2)
(display "Negation\n")
(cond
((finish?)
(display "kakutei-2\n")
(print-board))
(else
(loop))))
(else
(display "backtrack\n")
(solver2)))))