「パズルの解法 [7]」で作成したナンプレ解法プログラムを改造して、ナンプレを解く手順を表示するプログラムを作成しました。本プログラムでは行 (row) を数字 (1 - 9)、列 (col) を英字 (A - I)、枠 (box) を数字 (1 - 9) で表します。
A B C D E F G H I
+-------+-------+-------+
1 | | | |
2 | 枠 1 | 枠 2 | 枠 3 |
3 | | | |
+-------+-------+-------+
4 | | | |
5 | 枠 4 | 枠 5 | 枠 6 |
6 | | | |
+-------+-------+-------+
7 | | | |
8 | 枠 7 | 枠 8 | 枠 9 |
9 | | | |
+-------+-------+-------+
実装されている手筋は以下の通りです。
1 と 2 は本稿の確定サーチ (1), (2) のことで、次のように表示されます。
Naked single: A1 <- 5 Hidden single: A1 <- 5 : (col)
Hidden single の (col) は数字 5 を置けるマスは A 列の中でひとつ (A1) しかないこと表します。
3 も本稿や deepgreen さんのドキュメントと同じで、次のように表示されます。
Intersection: B3 delete (6) : (box 1 row 1) Intersection: A3 delete (6) : (box 1 row 1)
コロンの後ろの (box 1 row 1) は、枠 1 と行 1 の関係で手筋が成立したことを表します。マス B3 と A3 の候補数から 6 を削除します。
一般に、4 は二国同盟、5 は隠れ二国同盟と呼ばれることが多いようです。同様に、6 と 7 は三国同盟と隠れ三国同盟、8 と 9 は四国同盟と隠れ四国同盟と呼ばれます。deepgreen さんのドキュメントでは Enclosure (2, 3, 4) と Exclosure (2, 3, 4) に対応します。本稿では Enclosure でひとまとめにしていますが、本プログラムでは分けて表示するように改良しました。
Naked pair: F4 delete (5) : (D6 F6) Hidden pair: G6 delete (5) : (G6 I6)
コロンの後ろの (D6 F6) や (G6 I6) は、手筋が成立したマスの位置を表します。三国同盟であれば 3 つのマス、四国同盟であれば 4 つのマスが表示されます。そして、マス F4 と G6 の候補数から 5 を削除します。
本プログラムで唯一組み込まれている上級の手筋が X-Wing です。次のように表示されます。
X-Wing: A1 delete (3) : (B1 H1 B9 H9) X-Wing: I1 delete (3) : (B1 H1 B9 H9)
コロンの後ろのカッコは、手筋が成立したマスの位置を表します。マス A1 と I1 の候補数から 3 を削除します。
ここまでの手筋で問題が解けない場合は Negation (背理法) を使います。次のように表示されます。
Negation: B5 <- 2
Negation によりマス B5 の数字を 2 に決定します。Negation を使っても解けない問題は深さ優先探索で解を求めます。このとき、手筋は表示されません。
それでは、簡単な実行例として 数独 - Wikipedia の問題を解いてみましょう。
gosh[r7rs.user]> 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)) gosh[r7rs.user]> (solver q00) Naked single: E5 <- 5 Naked single: D6 <- 9 Naked single: E7 <- 3 Naked single: F7 <- 7 Naked single: I7 <- 4 Naked single: H8 <- 3 Naked single: E3 <- 4 Naked single: F3 <- 2 Naked single: I3 <- 7 Naked single: D4 <- 7 Naked single: B5 <- 2 Naked single: H5 <- 9 Naked single: D7 <- 5 Naked single: A8 <- 2 Naked single: C8 <- 7 Naked single: G8 <- 6 Naked single: F9 <- 6 Naked single: G9 <- 1 Naked single: D1 <- 6 Naked single: F1 <- 8 Naked single: I1 <- 2 Naked single: H2 <- 4 Naked single: I2 <- 8 Naked single: A3 <- 1 Naked single: D3 <- 3 Naked single: G3 <- 5 Naked single: G4 <- 4 Naked single: C5 <- 6 Naked single: G5 <- 7 Naked single: G6 <- 8 Naked single: H6 <- 5 Naked single: A7 <- 9 Naked single: C7 <- 1 Naked single: B8 <- 8 Naked single: A9 <- 3 Naked single: D9 <- 2 Naked single: C1 <- 4 Naked single: G1 <- 9 Naked single: H1 <- 1 Naked single: B2 <- 7 Naked single: C2 <- 2 Naked single: G2 <- 3 Naked single: F4 <- 1 Naked single: H4 <- 2 Naked single: B6 <- 1 Naked single: C6 <- 3 Naked single: F6 <- 4 Naked single: C9 <- 5 Naked single: B4 <- 5 Naked single: C4 <- 9 Naked single: B9 <- 4 kakutei 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 #<undef>
この問題は Naked single だけで解くことができます。ただし、上級の手筋が X-Wing しかないので、難しい問題を解かせると Negation が頻発することになるので、難問を解くときの参考にはならないでしょう。ですが、ナンプレ初級者の M.Hiroi には、けっこう役に立つプログラムです。上級の手筋を追加して、賢くするのも面白いと思います。興味のある方はプログラムを改造して遊んでみてください。
;;;
;;; numplace_talk.scm : ナンプレの解法
;;;
;;; Copyright (C) 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 *verbose* #t)
(define *numeral* '("null" "single" "pair" "triple" "quadruple"))
;;; デバッグ用
(define (print-flag)
(do ((y 0 (+ y 1)))
((>= y SIZE))
(do ((x 0 (+ x 1)))
((>= x SIZE) (newline))
(display (if (positive? (number-get y x)) '() (bits->list (flag-ref y x)))))))
;;; 組み合わせの生成
(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 '() '()))
;;; 座標を名前に変換 チェスと同じ
;;; column: A - I, row: 数字
(define (cell-name y x)
(let ((row "123456789")
(col "ABCDEFGHI"))
(string (string-ref col x) (string-ref row y))))
;;; 座標 (ドット対) のリストを名前に変換
(define (cell-name-list xs)
(map (lambda (p) (cell-name (car p) (cdr p))) xs))
;;; ビットを数値のリストに変換
(define (bits->list n)
(let loop ((n n) (a '()))
(if (zero? n)
(reverse a)
(let ((m (bitwise-and n (- n))))
(loop (bitwise-xor n m) (cons (bit-count (- m 1)) a))))))
;;; 数値のリストをビットに変換
(define (list->bits xs)
(foldl (lambda (a x) (bitwise-ior (arithmetic-shift 1 x) a)) 0 xs))
;;; 盤面のアクセス関数
(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 (space-position-x col)
(reverse
(block-fold
(lambda (a y x)
(if (zero? (number-get y x)) (cons (cons y x) a) a))
'()
0 SIZE col (+ col 1))))
(define (space-position-y row)
(reverse
(block-fold
(lambda (a y x)
(if (zero? (number-get y x)) (cons (cons y x) a) a))
'()
row (+ row 1) 0 SIZE)))
(define (space-position-g row col)
(reverse
(block-fold
(lambda (a y x)
(if (zero? (number-get y x)) (cons (cons y x) a) a))
'()
row (+ row 3) col (+ col 3))))
;;; フラグを消去する
(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 (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 (dfs-fast)
(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)
(dfs-fast)
(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-position y0 y1 x0 x1)
(list (cell-name y0 x0)
(cell-name y0 x1)
(cell-name y1 x0)
(cell-name y1 x1)))
(define (diagnoal-message n y x y0 y1 x0 x1)
(when
*verbose*
(display (string-append "X-Wing: " (cell-name y x) " delete "))
(display (bits->list n)) (display " : ")
(display (diagnoal-position y0 y1 x0 x1))
(newline)))
(define (diagnoal-column-flag-del! n y0 y1 x0 x1)
(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)))
(diagnoal-message n y x y0 y1 x0 x1)
(+ a 1))
(else a)))
0
0 SIZE x0 (+ x0 1)))
(define (diagnoal-line-flag-del! n x0 x1 y0 y1)
(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)))
(diagnoal-message n y x y0 y1 x0 x1)
(+ a 1))
(else a)))
0
y0 (+ y0 1) 0 SIZE))
(define (delete-column! n y0 y1 x0 x1)
(+ (diagnoal-column-flag-del! n y0 y1 x0 x1)
(diagnoal-column-flag-del! n y0 y1 x1 x0)))
(define (delete-line! n y0 y1 x0 x1)
(+ (diagnoal-line-flag-del! n x0 x1 y0 y1)
(diagnoal-line-flag-del! n x0 x1 y1 y0)))
(define (group-number y x)
(+ (* (quotient y 3) 3) (quotient x 3)))
(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-message n y x mes)
(when
*verbose*
(display "Intersection: ")
(display (string-append (cell-name y x) " delete "))
(display (bits->list n)) (display " : ")
(display mes)
(newline)))
(define (intersection-flag-del! n zs mes)
(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
(intersection-message (bitwise-and (flag-ref y x) n) y x mes)
(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 mes 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 mes)
(intersection-flag-del! (bitwise-and an cn (bitwise-not bn)) c mes))))))
(define (inter-row y x)
(list "box" (+ (group-number y x) 1) "row" (+ y 1)))
(define (inter-col y x)
(let ((col "ABCDEFGHI"))
(list "box" (+ (group-number y x) 1) "col" (string-ref col x 1))))
(define (intersection-g y x failure)
(let ((c 0)
(gs (partition-g-cell y x)))
(do ((i 0 (+ i 1)))
((>= i 3) c)
(set! c (+ c
(intersection-sub gs (partition-x-cell (+ x i)) (inter-col y (+ x i)) failure)
(intersection-sub gs (partition-y-cell (+ y i)) (inter-row (+ y i) x) failure))))))
(define (single-message n y x mes1 mes2)
(when
*verbose*
(display (string-append mes1 (cell-name y x) " <- "))
(display n)
(display mes2)
(newline)))
;;; 候補数が一つのマスを探す
(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)
(single-message (bit-count (- m 1)) y x "Naked single: " "")
(number-set! y x m)
(delete-flag! y x m)
(+ c 1))
(else c)))
c))
0
0 SIZE 0 SIZE))
;;; 候補数字 n の位置を求める
(define (collect-number-position m y0 y1 x0 x1)
(block-fold
(lambda (a y x)
(if (and (zero? (number-get y x))
(positive? (bitwise-and (flag-ref y x) m)))
(cons (cons y x) a)
a))
'()
y0 y1 x0 x1))
;;; 縦横枠で候補が一つの数字を探す
(define (search-x)
(do ((c 0)
(x 0 (+ x 1)))
((>= x SIZE) c)
(do ((n 1 (+ n 1)))
((> n SIZE))
(let* ((m (arithmetic-shift 1 n))
(ps (collect-number-position m 0 SIZE x (+ x 1))))
(when
(= (length ps) 1)
(let ((y1 (caar ps)) (x1 (cdar ps)))
(single-message n y1 x1 "Hidden single: " " : (col)")
(number-set! y1 x1 m)
(delete-flag! y1 x1 m)
(set! c (+ c 1))))))))
(define (search-y)
(do ((c 0)
(y 0 (+ y 1)))
((>= y SIZE) c)
(do ((n 1 (+ n 1)))
((> n SIZE))
(let* ((m (arithmetic-shift 1 n))
(ps (collect-number-position m y (+ y 1) 0 SIZE)))
(when
(= (length ps) 1)
(let ((y1 (caar ps)) (x1 (cdar ps)))
(single-message n y1 x1 "Hidden single: " " : (row)")
(number-set! y1 x1 m)
(delete-flag! y1 x1 m)
(set! c (+ c 1))))))))
(define (search-g)
(do ((c 0)
(y 0 (+ y 3)))
((> y 6) c)
(do ((x 0 (+ x 3)))
((> x 6))
(do ((n 1 (+ n 1)))
((> n SIZE))
(let* ((m (arithmetic-shift 1 n))
(ps (collect-number-position m y (+ y 3) x (+ x 3))))
(when
(= (length ps) 1)
(let ((y1 (caar ps)) (x1 (cdar ps)))
(single-message n y1 x1 "Hidden single: " " : (box)")
(number-set! y1 x1 m)
(delete-flag! y1 x1 m)
(set! c (+ c 1)))))))))
;;;
;;; Exclosure
;;;
(define (exclosure-message n k y x xs)
(when
*verbose*
(display "Hidden ") (display (list-ref *numeral* n)) (display ": ")
(display (string-append (cell-name y x) " delete "))
(display (bits->list (bitwise-and (flag-ref y x) (bitwise-not k))))
(display " : ")
(display (cell-name-list xs))
(newline)))
;;; 数値 k が存在するマスを求める
(define (exclosure-position k ps)
(filter (lambda (p) (positive? (bitwise-and (flag-ref (car p) (cdr p)) k))) ps))
;;; n 個数, ls 空き場所
(define (exclosure-sub n ls failure)
(foldl
(lambda (a xs)
(let* ((k (list->bits xs)) ; 選んだ数字 xs をビットに変換
(ys (exclosure-position k ls)) ; k を含むマスを求める
(c (length ys)))
(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) (bitwise-not k))) b)
(else
(exclosure-message n k y x ys)
(flag-set! y x (bitwise-and (flag-ref y x) k))
(+ b 1)))))
a
ys))
(else a))))
0
(combinations-list n (bits->list (collect-numbers ls)))))
;;;
;;; Enclosure
;;;
(define (enclosure-message n m y x xs)
(when
*verbose*
(display "Naked ") (display (list-ref *numeral* n)) (display ": ")
(display (string-append (cell-name y x) " delete "))
(display (bits->list (bitwise-and (flag-ref y x) m)))
(display " : ")
(display (cell-name-list xs))
(newline)))
(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
(enclosure-message n m y x xs)
(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 n failure)
(do ((c 0)
(x 0 (+ x 1)))
((>= x SIZE) c)
(let ((ps (space-position-x x)))
(set! c (+ c
(enclosure-sub n ps failure)
(exclosure-sub n ps failure))))))
(define (enclosure-y n failure)
(do ((c 0)
(y 0 (+ y 1)))
((>= y SIZE) c)
(let ((ps (space-position-y y)))
(set! c (+ c
(enclosure-sub n ps failure)
(exclosure-sub n ps failure))))))
(define (enclosure-g n failure)
(do ((c 0)
(y 0 (+ y 3)))
((> y 6) c)
(do ((x 0 (+ x 3)))
((> x 6))
(let ((ps (space-position-g y x)))
(set! c (+ c
(enclosure-sub n ps failure)
(exclosure-sub n ps failure)))))))
(define (enclosure-loop)
(call/cc
(lambda (failure)
(let loop ()
(if (and (zero? (search-cell failure))
(zero? (+ (search-x) (search-y) (search-g)))
(zero? (intersection-g 0 0 failure))
(zero? (intersection-g 0 3 failure))
(zero? (intersection-g 0 6 failure))
(zero? (intersection-g 3 0 failure))
(zero? (intersection-g 3 3 failure))
(zero? (intersection-g 3 6 failure))
(zero? (intersection-g 6 0 failure))
(zero? (intersection-g 6 3 failure))
(zero? (intersection-g 6 6 failure))
(zero? (enclosure-g 2 failure))
(zero? (enclosure-y 2 failure))
(zero? (enclosure-x 2 failure))
(zero? (enclosure-g 3 failure))
(zero? (enclosure-y 3 failure))
(zero? (enclosure-x 3 failure))
(zero? (enclosure-g 4 failure))
(zero? (enclosure-y 4 failure))
(zero? (enclosure-x 4 failure)))
(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 (negation-message m y x)
(display (string-append "Negation: " (cell-name y x) " <- "))
(display (bit-count (- m 1)))
(newline))
(define (negation)
(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)
(let ((result (enclosure-loop)))
(restore-board)
(cond
((not result)
;; 矛盾する (もう一つの値が正解)
(let ((m (bitwise-and (flag-ref y x) (bitwise-not n))))
(negation-message m y x)
(number-set! y x m)
(delete-flag! y x m)
(break #t)))
((finish?)
;; n で解けた
(negation-message n y x)
(number-set! y x n)
(delete-flag! y x n)
(break #t)))))
(flag-ref y x))))
0 SIZE 0 SIZE)
#f)))
;;; 解けたか
(define (finish?) (zero? *space*))
;;; ナンプレの解法
(define (solver qs)
(init-board qs)
(let loop ()
(cond
((not (enclosure-loop))
(error "data error"))
((finish?)
(display "kakutei\n")
(print-board))
((positive? (diagnoal))
(loop))
(else
(set! *verbose* #f)
(let ((result (negation)))
(set! *verbose* #t)
(cond
(result
(loop))
(else
(display "backtracking\n")
(dfs-fast))))))))