前回は Enclosure と Negation という確定的アルゴリズムを使った解法プログラムを作りました。deepgreen さんのドキュメント『ナンバープレース(数独) 解法アルゴリズム』によると、確定的アルゴリズムは Enclosure と Negation だけではなく Intersection という方法もあります。前回のプログラムは Intersection を Negation で代用しているわけです。
そもそも Negation (背理法) を使わなければ解けない問題は、人手で解くとなると試行錯誤が必要になるため、面白みに欠けるという意見が多いようです。このため、背理法を必要とする問題はごく少数で、Enclosure と Intersection を繰り返し適用するだけでも、多くの問題を解くことができるように思います。そこで、今回は Intersection という確定的アルゴリズムを実装して、背理法を使わなくても難しい問題を解くことができるか試してみましょう。
Intersection は「行と枠」または「列と枠」の重複部分を利用した方法です。名前の由来は集合演算の intersection だと思います。次の図を見てください。
┏━┯━┯━┳━┯━┯━┳━┯━┯━┓
┃Ａ│Ａ│Ａ┃Ｂ│Ｂ│Ｂ┃Ｂ│Ｂ│Ｂ┃
┠─┼─┼─╂─┼─┼─╂─┼─┼─┨
┃Ｃ│Ｃ│Ｃ┃
┠─┼─┼─╂
┃Ｃ│Ｃ│Ｃ┃
┣━┿━┿━╋
(1) 数字の候補 K が A, B にある場合 -> B にある K を削除
(2) 数字の候補 K が A, C にある場合 -> C にある K を削除
(3) 数字の候補 K が A, B, C にある場合 -> 何も決定できない
(4) 数字の候補 K が B, C にある場合 -> 何も決定できない
(5) 数字の候補 K が A しかない場合 -> 何も決定できない
(6) それ以外の場合 -> 解なし
図 : Intersection の条件
行と枠の重複部分を A とし、行だけの部分を B、枠だけの部分を C とします。数字の候補を K とすると、条件 (1) は K が A と B にあり C にはない場合です。この場合、B から K を選ぶと 枠に K を割り当てることができなくなります。したがって、K は A から選ばなければならず、B から K を削除することができます。
条件 (2) は K が A と C にあり、B にはない場合です。この場合、C から K を選ぶと行に K を割り当てることができなくなります。したがって、K は A から選ばなければならず、C から K を削除することができます。それ以外の場合、K を削除することはできません。
解なしの条件ですが、数字の候補 K が B または C にしかない場合です。このとき、枠 (A, C) または行 (A, B) で数字 K が決定していれば、矛盾はしないので「解なし」の条件を満たさないことに注意してください。
具体的な例を示しましょう。次の図を見てください。
0 2 0 ,,, (9 7 6 4 3 1) () (9 4 3 1) ...
8 0 0 ... () (9 7 6 4 1) (9 4 3 1) ...
0 0 5 ... (9 6 3 1) (9 6 1) () ...
0 0 6 ... (9 5 4 3) (9 8 5 4) () ...
0 0 0 ... (9 7 5 4) (9 8 7 5 4) (9 8 4) ...
0 0 2 ... (9 7 4 3 1) (9 8 7 4 1) () ...
0 0 7 ... (9 1) (9 8 1) () ...
2 0 0 ... () (6 5) (9 8 4 1) ...
0 3 0 ... (6 5) () (9 4 1) ...
図 : Intersection の具体例
ある問題で Enclosure を適用したあと、上図の状態になったとします。左図が盤面 (一部) で右図が候補となる数字を表します。右端の列と 1 段目の枠に注目してください。数字 3 は重複部分と枠の中にはありますが、列だけの部分にはありません。この場合、枠だけの部分から数字 3 を削除することができます。したがって、(9 7 6 4 3 1) は (9 7 6 4 1) に、(9 6 3 1) は (9 6 1) になります。
次は右端の列と 3 段目の枠に注目してください。数字 4 は重複部分と列の中にはありますが、枠だけの部分にはありません。この場合、列だけの部分から数字 4 を削除することができます。したがって、2 つある (9 4 3 1) は (9 3 1) に、(9 8 4) は (9 8) になります。
このように、Intersection を適用して数字の候補数を減らすことができます。このあと、Enclosure を再度適用することで、数字の候補数を減らして数字を決定できる場合があります。たとえば、1 段目の枠に Enclosure を適用すると次のようになります。
(9 7 6 4 1) () (9 3 1) (7 4) () (9 3 1) () (9 7 6 4 1) (9 3 1) == Enclosure => () (7 4) (9 3 1) (9 6 1) (9 6 1) () (9 6 3 1) (9 6 1) (9 6 1) ()
4 つのマス (9 3 1), (9 3 1), (9 6 1), (9 6 1) で Enclosure が成立するので、2 つのマス (9 7 6 4 1) から 9, 6, 1 を削除することができます。このように、Enclosure と Intersection を繰り返し適用することで、数字の候補を減らして数字を決定することができます。それでも解けない問題は Negation を適用すればいいわけです。
それではプログラムを作りましょう。まず最初に、枠と縦横方向の関係で Intersection をチェックする関数 intersection-g を作ります。
リスト : Intersection
(define (intersection-g failure)
(do ((c 0)
(y 0 (+ y 3)))
((> y 6) c)
(do ((x 0 (+ x 3)))
((> x 6))
(let ((gs (partition-g-cell y x)))
(do ((i 0 (+ i 1)))
((>= i 3))
(set! c (+ c
(intersection-sub gs (partition-x-cell (+ x i)) failure)
(intersection-sub gs (partition-y-cell (+ y i)) failure))))))))
引数 failure は「解なし」のときに処理を中断するための継続です。二重の do ループで 9 つの枠をチェックします。partition-g-cell は枠の中、partition-x-cell は縦方向、partition-y-cell は横方向の空きマスと数字が決まったマスを求める関数です。返り値はリストで、先頭要素が空きマスを格納したリスト、2 番目の要素が数字が決まったマスを格納したリストです。実際の処理は関数 intersection-sub で行います。
リスト : Intersection の条件をチェックする
(define (intersection-sub gs zs failure)
(let* ((a (intersection equal? (car gs) (car zs)))
(b (difference equal? (car zs) a))
(c (difference equal? (car gs) a))
(an (collect-numbers a))
(bn (collect-numbers b))
(cn (collect-numbers c))
(only-bn (bitwise-and bn (bitwise-not (bitwise-ior an cn))))
(only-cn (bitwise-and cn (bitwise-not (bitwise-ior an bn)))))
(cond
((and (positive? only-bn)
(not (check-numbers only-bn (cadr gs))))
(failure #f))
((and (positive? only-cn)
(not (check-numbers only-cn (cadr zs))))
(failure #f))
(else
(+ (intersection-flag-del! (bitwise-and an bn (bitwise-not cn)) b)
(intersection-flag-del! (bitwise-and an cn (bitwise-not bn)) c))))))
引数 gs が枠のマス、zs が行または列のマスを格納したリストです。最初に、空きマスの共通部分を変数 a に、行 (または列) だけの空きマスを変数 b に、枠だけの部分を変数 c にセットします。次に、a, b, c で候補の数字を collect-numbers で求めて変数 an, bn, cn にセットします。そして、b だけにある数字の候補を変数 only-bn に、c だけにある数字の候補を変数 only-cn にセットします。only-bn と only-cn はビット演算で簡単に求めることができます。
次の cond で「解なし」の条件をチェックします。only-bn に数字があり、その数字が枠の中で決まっていなければ、継続 failure を評価して #f を返します。check-numbers は第 1 引数の数字が第 2 引数のマスにあるならば #t を返します。なければ #f を返します。同様に only-cn に数字があり、行 (または列) の中でその数字が決まっていなければ、failure で #f を返します。
最後に、関数 intersection-flag-del! でフラグをクリアします。最初が a と b に数字があり、c に数字がない場合です。この数字を b から削除します。次が a と c に数字があり、b に数字ない場合です。この数字を c から削除します。
次は関数 intersection-flag-del! を作ります。
リスト : Intersection が成立していればフラグをクリアする
(define (intersection-flag-del! n zs)
(if (zero? n)
0
(foldl
(lambda (a p)
(let ((y (car p)) (x (cdr p)))
(cond
((zero? (bitwise-and n (flag-ref y x))) a)
(else
(flag-set! y x (bitwise-and (flag-ref y x) (bitwise-not n)))
(+ a 1)))))
0
zs)))
引数 n が 0 ならば削除する数字が無いので 0 を返します。そうでなければ、foldl で zs のマスから数字 n を削除します。ラムダ式の中で、実際に数字を削除できたならば累積変数 a の値を +1 して返します。削除できなければ a をそのまま返します。
最後に enclosure-loop を修正します。
リスト : Enclosure と Intersection のチェックを繰り返し行う
(define (enclosure-loop)
(call/cc
(lambda (failure)
(let loop ()
(if (zero? (+ (search-cell failure)
(enclosure get-x-cell failure)
(enclosure get-y-cell failure)
(enclosure get-g-cell failure)
(intersection-g failure)))
#t
(loop))))))
enclosure のあとで intersection-g を呼び出すだけです。あとのプログラムは簡単なので説明は割愛します。詳細はプログラムリストをお読みくださいませ。
それでは、実際にナンプレを解いてみましょう。deepgreen さんが作成された「ナンプレ問題集」より問題 9909-c1, 9909-d1, 9909-e1, 9909-h1, 9909-h2 と、Arto Inkala さんが作成された問題を試してみたところ、実行時間は次のようになりました。
表 : 実行結果 (単位 : 秒) 問題 : Hint : (5) : (6) ------+------+-----------+----------- c1 : 22 : 0.096 (6) : 0.11 (6) d1 : 21 : 0.033 : 0.027 e1 : 24 : 0.028 (1) : 0.033 (1) h1 : 23 : 0.025 : 0.026 h2 : 24 : 0.031 : 0.028 問題 : Hint : (5) : (6) ------+------+------+------ １ : 23 : 0.21 : 0.28 ２ : 21 : 0.72 : 0.65 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 だけでも解くことができます。Intersection でもフラグは削除していますが、Intersection の処理はちょっと複雑で時間がかかるため、実行時間は (5) とほぼ同じくらいでした。c1 と d1 は Enclosure と Intersection だけでは解くことができず、Negation が必要になりました。問題 1, 2 は Enclousre, Intersection, Negation では解くことができませんでした。
この結果だけみると、Intersecction の効果は少ないように思いますが、問題によって効果は大きく変わります。たとえば、Puzzle Generater Japan (リンク切れ) の Java版超難問集 (リンク切れ) の超難問 534, 580, 849, 1122 を試してみたところ、実行時間は次のようになりました。
表 : 実行結果 (単位 : 秒)
: Intersection
問題 : Hint : 無 : 有
------+------+----------+-------
534 : 24 : 0.15 (3) ; 0.074
580 : 24 : 0.25 (3) : 0.077
849 : 24 : 0.11 (3) : 0.079
1122 : 24 : 0.10 (2) : 0.058
実行環境 : Gauche ver 0.9.9, Ubunts 18.04 (WSL), Intel Core i5-6200U 2.30GHz
Intersection が無い場合、カッコ内の数字は Negation を適用した回数を表します。Intersection が有る場合、どの問題も Negation を適用せずに解くことができ、実行時間も短縮されました。
また、数独無料問題集の『世界一難しい数独問題の紹介』にある渡辺先生が作成された問題は、Enclosure と Negation だけではバックトラックが必要になりますが、Intersection を適用すると、バックトラックせずに解くことができるようになります。
Enclosure, Intersection, Negation だけですべての問題を解くことはできませんでしたが、これだけでもかなりの問題に対応できるのではないか、と思っています。M.Hiroi は上級といわれる手筋をほとんど知らないのですが、それらを追加すればもっと多くの問題をバックトラックせずに解けるかもしれません。興味のある方は挑戦してみてください。
今回のプログラムを作成するにあたり、deepgreen さんの Web サイト Computer Puzzle Solution で公開されているドキュメント『ナンバープレース(数独) 解法アルゴリズム』を参考にさせていただきました。素晴らしいドキュメントを公開されている deepgreen さんに深く感謝いたします。
今回作成したプログラム (numplace6.scm) に上級の手筋といわれている「井桁理論 (X-WING)」を追加しました。井桁理論については多くの Web サイトで解説されているので、ここでは説明を割愛させていただきます。パズル政策研究所様の『ナンバープレース解き方テクニック集』の「テクニック11 - 井形レーザー」の問題が解けたので、プログラムは正常に動作していると思いますが、まだバグがあるかもしれません。興味のある方はいろいろ試してみてください。
;;;
;;; numplace6.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))))))
;;;
;;; 井桁理論 (対角線の理論, X-WING)
;;;
;;; 候補の数字をカウントする
(define (number-count n y0 y1 x0 x1)
(block-fold
(lambda (a y x)
(if (and (zero? (number-get y x))
(positive? (bitwise-and (flag-ref y x) n)))
(+ a 1)
a))
0
y0 y1 x0 x1))
;;; 縦方向のチェック
(define (check-column n x0 x1)
(= 2
(number-count n 0 SIZE x0 (+ x0 1))
(number-count n 0 SIZE x1 (+ x1 1))))
;;; 横方向のチェック
(define (check-line n y0 y1)
(= 2
(number-count n y0 (+ y0 1) 0 SIZE)
(number-count n y1 (+ y1 1) 0 SIZE)))
;;; 縦方向のフラグをクリア
(define (diagnoal-column-flag-del! n y0 y1 x0)
(block-fold
(lambda (a y x)
(cond
((and (not (= y y0))
(not (= y y1))
(zero? (number-get y x))
(positive? (bitwise-and (flag-ref y x) n)))
(flag-set! y x (bitwise-and (flag-ref y x) (bitwise-not n)))
(+ a 1))
(else a)))
0
0 SIZE x0 (+ x0 1)))
(define (delete-column! n y0 y1 x0 x1)
(+ (diagnoal-column-flag-del! n y0 y1 x0)
(diagnoal-column-flag-del! n y0 y1 x1)))
;;; 横方向のフラグをクリア
(define (diagnoal-line-flag-del! n x0 x1 y0)
(block-fold
(lambda (a y x)
(cond
((and (not (= x x0))
(not (= x x1))
(zero? (number-get y x))
(positive? (bitwise-and (flag-ref y x) n)))
(flag-set! y x (bitwise-and (flag-ref y x) (bitwise-not n)))
(+ a 1))
(else a)))
0
y0 (+ y0 1) 0 SIZE))
(define (delete-line! n y0 y1 x0 x1)
(+ (diagnoal-line-flag-del! n x0 x1 y0)
(diagnoal-line-flag-del! n x0 x1 y1)))
;;; 枠 (グループ) の番号を求める
(define (group-number y x)
(+ (* (quotient y 3) 3) (quotient x 3)))
;;; 4 つのマスが同じ枠内にあるか
(define (same-group? y0 y1 x0 x1)
(= (group-number y0 x0) (group-number y0 x1)
(group-number y1 x0) (group-number y1 x0)))
;;; 井桁理論 (対角線)
(define (diagnoal)
(do ((c 0)
(y0 0 (+ y0 1)))
((>= y0 SIZE) c)
(do ((x0 0 (+ x0 1)))
((>= x0 SIZE))
(when
(zero? (number-get y0 x0))
(do ((y1 (+ y0 1) (+ y1 1)))
((>= y1 SIZE))
(when
(zero? (number-get y1 x0))
(do ((x1 (+ x0 1) (+ x1 1)))
((>= x1 SIZE))
(when
(and (zero? (number-get y0 x1))
(zero? (number-get y1 x1))
(not (same-group? y0 y1 x0 x1)))
(let ((m (bitwise-and (flag-ref y0 x0)
(flag-ref y1 x0)
(flag-ref y0 x1)
(flag-ref y1 x1))))
(when
(positive? m)
(bit-for-each
(lambda (n)
;; 縦方向に n がない -> 横方向の n をクリア
;; 横方向に n がない -> 縦方向の n をクリア
(cond
((check-column n x0 x1)
(set! c (+ c (delete-line! n y0 y1 x0 x1))))
((check-line n y0 y1)
(set! c (+ c (delete-column! n y0 y1 x0 x1))))))
m)))))))))))
;;;
;;; Intersection
;;;
(define (collect-numbers xs)
(foldl (lambda (a p) (bitwise-ior (flag-ref (car p) (cdr p)) a)) 0 xs))
(define (partition-cell y1 y2 x1 x2)
(block-fold
(lambda (a y x)
(let ((b (car a))
(c (cadr a))
(z (cons y x)))
(if (zero? (number-get y x))
(list (cons z b) c)
(list b (cons z c)))))
(list '() '())
y1 y2 x1 x2))
(define (partition-g-cell y x)
(partition-cell y (+ y 3) x (+ x 3)))
(define (partition-x-cell x)
(partition-cell 0 SIZE x (+ x 1)))
(define (partition-y-cell y)
(partition-cell y (+ y 1) 0 SIZE))
(define (intersection-flag-del! n zs)
(if (zero? n)
0
(foldl
(lambda (a p)
(let ((y (car p)) (x (cdr p)))
(cond
((zero? (bitwise-and n (flag-ref y x))) a)
(else
(flag-set! y x (bitwise-and (flag-ref y x) (bitwise-not n)))
(+ a 1)))))
0
zs)))
(define (check-numbers n zs)
(define (check-num m zs)
(let loop ((zs zs))
(if (null? zs)
#f
(or (= (number-get (caar zs) (cdar zs)) m)
(loop (cdr zs))))))
(call/cc
(lambda (break)
(bit-for-each
(lambda (m)
(unless (check-num m zs) (break #f)))
n)
#t)))
(define (intersection-sub gs zs failure)
(let* ((a (intersection equal? (car gs) (car zs)))
(b (difference equal? (car zs) a))
(c (difference equal? (car gs) a))
(an (collect-numbers a))
(bn (collect-numbers b))
(cn (collect-numbers c))
(only-bn (bitwise-and bn (bitwise-not (bitwise-ior an cn))))
(only-cn (bitwise-and cn (bitwise-not (bitwise-ior an bn)))))
(cond
((and (positive? only-bn)
(not (check-numbers only-bn (cadr gs))))
(display "intersection fail\n")
(failure #f))
((and (positive? only-cn)
(not (check-numbers only-cn (cadr zs))))
(display "intersection fail\n")
(failure #f))
(else
(+ (intersection-flag-del! (bitwise-and an bn (bitwise-not cn)) b)
(intersection-flag-del! (bitwise-and an cn (bitwise-not bn)) c))))))
(define (intersection-g failure)
(do ((c 0)
(y 0 (+ y 3)))
((> y 6) c)
(do ((x 0 (+ x 3)))
((> x 6))
(let ((gs (partition-g-cell y x)))
(do ((i 0 (+ i 1)))
((>= i 3))
(set! c (+ c
(intersection-sub gs (partition-x-cell (+ x i)) failure)
(intersection-sub gs (partition-y-cell (+ y i)) failure))))))))
;;;
;;; 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 (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)
;(intersection-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))
((positive? (diagnoal))
(display "diagnoal\n")
(loop))
((negation1)
(display "Negation\n")
(cond
((finish?)
(display "kakutei-2\n")
(print-board))
(else
(loop))))
(else
(display "backtrack\n")
(solver2)))))