「数独」の続きです。前回は Enclosure と Negation (背理法) という確定的アルゴリズムを使った解法プログラムを作りました。deepgreen さん のドキュメント (ナンバープレース(数独) 解法アルゴリズム) によると、確定的アルゴリズムは Enclosure と Negation だけではなく Intersection という方法もあります。前回のプログラムは Intersection を 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 を削除することはできません。
今回は Intersection の条件 (1) と (2) のチェックだけを行い、「解なし」のチェックは行わないことにします。
具体的な例を示しましょう。次の図を見てください。
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-x と、横方向と枠の関係でチェックする関数 intersection-y を作ります。
リスト : Intersection
; 縦方向
(define (intersection-x)
(fold
(lambda (x a) (+ (intersection-sub (get-x-cell x)) a))
0
'(0 1 2 3 4 5 6 7 8)))
; 横方向
(define (intersection-y)
(fold
(lambda (x a) (+ (intersection-sub (get-y-cell x)) a))
0
'(0 1 2 3 4 5 6 7 8)))
実際の処理は関数 intersection-sub で行います。どちらの関数も 1 行 (1 列) ずつ順番に調べていきます。返り値は Intersection が成立して実際にフラグをクリアした回数になります。
次は Intersection の条件をチェックする関数 intersection-sub を作ります。
リスト : Intersection の条件をチェックする
(define (intersection-sub xs)
; xs にしかない数字の候補を求める
(define (number-difference xs ys)
(logand (collect-numbers xs) (lognot (collect-numbers ys))))
; 本体
(fold
(lambda (zs cnt)
(let ((a (filter space? zs)))
(if (null? a)
cnt ; 空き場所なし
(let* ((gs (filter space? (get-g-cell (get-g (car a))))) ; 枠の空き場所
(b (lset-difference eqv? (filter space? xs) a))
(c (lset-difference eqv? gs a)))
(intersection-flag-clear!
(number-difference a b)
(intersection-flag-clear! (number-difference a c) cnt b)
c)))))
0
(group xs 3)))
まず関数 group で行 (または列) を 3 つのグループに分けて、本体の fold に渡します。ラムダ式の引数 zs が 3 つの要素を格納したリストで、これが枠との重複部分になります。次に、zs の空き場所を求めて変数 a にセットします。空き場所がなければ Intersection のチェックは行わずに累積変数 cnt を返します。
空き場所がある場合、枠の空き場所を求めて変数 gs にセットします。リスト a には枠との重複部分が格納されているので、その位置から枠の空き場所を求めることができます。そして、行 (または列) だけの部分を変数 b に、枠だけの部分を変数 c にセットします。これは集合演算を行う関数 lset-difference を使うと簡単に求めることができます。
そして、a と b (または c) の数字の候補を求め、a だけに存在する数字の候補を求めます。この処理は関数 number-difference で行います。a と b を調べて、a だけにある数字が見つかった場合、その数字を c の候補から削除します。この処理は関数 intersection-flag-clear! で行います。a と c を調べた場合は、b から数字を削除することに注意してください。
次は関数 intersection-flag-clear! を作ります。
リスト : Intersection が成立していればフラグをクリアする
(define (intersection-flag-clear! m a ls)
(if (or (zero? m) (null? ls))
a
(+ a (delete-flag! m ls))))
引数 m は重複部分だけにある数字、a はフラグをクリアした回数を保持する累積変数、ls が行 (または列) だけの部分です。m が 0 または ls が空リストの場合は a をそのまま返します。そうでなければ、delete-flag! でフラグをクリアするだけです。
最後に 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-x)
(intersection-y)))
#t
(loop))))))
enclosure のあとで intersection-x, intersection-y を呼び出すだけです。プログラムの修正はこれで完了です。
それでは、実際に数独を解いてみましょう。Puzzle Generater Japan にある Java版超難問集 の超難問 534, 580, 849, 1122 を試してみたところ、実行時間は次のようになりました。
表 : 実行結果 (単位 : 秒)
: Intersection
問題 : Hint : 無 : 有
------+------+-----------+-------
534 : 24 : 0.160 (3) ; 0.037
580 : 24 : 0.078 (3) : 0.033
849 : 24 : 0.120 (3) : 0.034
1122 : 24 : 0.120 (2) : 0.039
実行環境 : Windows 7, Core i7-2670QM 2.20GHz, Gauche ver 0.9.2
Intersection が無い場合、カッコ内の数字は Negation を適用した回数を表します。Intersection が有る場合、どの問題も Negation を適用せずに解くことができ、実行時間も短縮されました。
なお、Intersection を適用したからといって、必ず高速に解けるとは限りません。問題によっては、かえって遅くなる場合もあります。実際、deepgreen さんの おまけ − ナンプレ問題集 の中には、Intersection を適用すると Negation の回数は減少するが実行時間は少し遅くなる、という問題がありました。
ところで、M.Hiroi がいろいろな問題を試してみたところ、数独の多くの問題は Enclosure と Intersection を繰り返し適用することで解くことができるようです。それでは、Enclosure, Intersection, Negation ですべての問題を解くことができるのでしょうか。残念ながら、下記 URL に掲載されているフィンランドの数学者 Arto Inkala さんが作成された問題は、Enclosure, Intersection, Negation だけでは解くことができず、深さ優先探索を実行しないと解を見つけることができません。
ご参考までに実行時間を示します。
表 : 実行結果 (単位 : 秒) 問題 : (3a) : (a) : (b) ------+-------+------+------ １ : 0.067 : 0.81 : 2.53 ２ : 0.80 : 1.70 : 4.95 (a) negation1 (b) negation2 実行環境 : Windows 7, Core i7-2670QM 2.20GHz, Gauche ver 0.9.2
Negation の処理に時間がかかるため、実行時間は前々回作成したプログラム (3a) よりもかなり遅くなりました。どちらの問題も Negation では数字を確定することができず、negation2 でいくつかのフラグをクリアするのが精一杯でした。他の手筋を使うと解けるのかもしれませんが、M.Hiroi は上級といわれる手筋をほとんど知らないので、ここであきらめてしまいました。また、M.Hiroi のプログラムに不具合があるのかもしれません。何かお気づきの点がありましたら、ご教示お願いいたします。
今回のプログラムを作成するにあたり、deepgreen さんの Web サイト Computer Puzzle Solution で公開されているドキュメント ナンバープレース(数独) 解法アルゴリズム を参考にさせていただきました。素晴らしいドキュメントを公開されている deepgreen さんに深く感謝いたします。
;
; nplace.scm : 数独の解法
; (Intersection の実装)
;
; Copyright (C) 2013 Makoto Hiroi
;
(use srfi-1)
; ビット用高階関数
(define (bit-for-each func n)
(let loop ((n n))
(if (positive? n)
(let ((m (logand (- n) n)))
(func m)
(loop (logxor n m))))))
; 定数
(define SIZE 9)
(define SIZE2 (* SIZE SIZE))
; 盤面
(define *board* #f)
; フラグ
(define *flag* #f)
; 縦、横、枠の位置を格納する
(define *xyg-tbl* #f)
(define *x-tbl* #f)
(define *y-tbl* #f)
(define *g-tbl* #f)
; 盤面とフラグのアクセス関数
(define (get-number k) (vector-ref *board* k))
(define (put-number! n k) (vector-set! *board* k n))
(define (get-flag k) (vector-ref *flag* k))
(define (put-flag! n k) (vector-set! *flag* k n))
; 縦横枠のマスを求める
(define (get-cell k) (vector-ref *xyg-tbl* k))
; 縦方向のマスを求める
(define (get-x-cell k) (vector-ref *x-tbl* k))
; 横方向のマスを求める
(define (get-y-cell k) (vector-ref *y-tbl* k))
; 枠内のマスを求める
(define (get-g-cell k) (vector-ref *g-tbl* k))
; 添字 -> 座標
(define (get-x k) (modulo k SIZE))
(define (get-y k) (quotient k SIZE))
(define (get-g k)
(+ (quotient (get-x k) 3) (* (quotient (get-y k) 3) 3)))
; 空き場所か？
(define (space? k) (zero? (get-number k)))
; テーブルの初期化
(define (init-tbl)
(set! *x-tbl*
(list->vector (map (lambda (k) (iota SIZE k SIZE))
(iota SIZE 0))))
(set! *y-tbl*
(list->vector (map (lambda (k) (iota SIZE (* k SIZE)))
(iota SIZE 0))))
(set! *g-tbl*
(list->vector
(map (lambda (k)
(let ((start (vector-ref #(0 3 6 27 30 33 54 57 60) k)))
(map (lambda (x) (+ start x))
'(0 1 2 9 10 11 18 19 20))))
(iota SIZE 0))))
(set! *xyg-tbl*
(list->vector (map (lambda (p)
(sort (lset-union eqv?
(get-x-cell (get-x p))
(get-y-cell (get-y p))
(get-g-cell (get-g p)))))
(iota SIZE2 0)))))
; フラグを消す
(define (delete-flag! n ls)
(let ((m (lognot n)))
(fold
(lambda (k a)
(cond ((and (space? k)
(positive? (logand (get-flag k) n)))
(put-flag! (logand (get-flag k) m) k)
(+ a 1))
(else a)))
0
ls)))
; フラグの初期化
(define (init-flag)
(set! *flag* (make-vector SIZE2 #x3fe))
(dotimes (i SIZE2)
(let ((n (get-number i)))
(when (positive? n)
(put-flag! 0 i)
(delete-flag! n (get-cell i))))))
; 数字を決定する
(define (decide-number! n k)
(put-number! n k)
(put-flag! 0 k)
(delete-flag! n (get-cell k)))
; 数字をビットに変換する
(define (make-bit-board qs)
(list->vector (map (lambda (x) (if (zero? x) x (ash 1 x))) qs)))
; 盤面の表示
(define (print-bit-board)
(dotimes (x SIZE2)
(display (logcount (- (get-number x) 1)))
(display " ")
(if (= (modulo x SIZE) 8) (newline))))
;;
;; バックトラックによる解法
;;
; フラグのセーブ
(define (save-flag k)
(fold
(lambda (x a) (cons (cons (get-flag x) x) a))
'()
(get-cell k)))
; フラグのリストア
(define (restore-flag xs)
(for-each
(lambda (x) (put-flag! (car x) (cdr x)))
xs))
; 置ける数字が最も少ないマスを探す
(define (search-min-cell)
(vector-fold
(lambda (k a n)
(if (positive? n)
a
(let ((c (logcount (get-flag k))))
(if (< c (cdr a))
(cons k c)
a))))
'(#f . 10)
*board*))
; 深さ優先探索
(define (dfs1)
(let ((k (car (search-min-cell))))
(if (not k)
(print-bit-board)
(let ((xs (save-flag k)))
(bit-for-each
(lambda (n)
(decide-number! n k)
(dfs1)
(restore-flag xs)
(put-number! 0 k))
(get-flag k))))))
; バックトラックによる解法
(define (solver qs)
(set! *board* (make-bit-board qs))
(init-flag)
(dfs1))
;;
;; Intersection
;;
; リストのグループ分け
(define (group ls n)
(if (null? ls)
'()
(cons (take ls n) (group (drop ls n) n))))
; Intersection が成立していればフラグをクリアする
(define (intersection-flag-clear! m a ls)
(if (or (zero? m) (null? ls))
a
(+ a (delete-flag! m ls))))
; Intersection の条件をチェック
(define (intersection-sub xs)
; xs にしかない数字の候補を求める
(define (number-difference xs ys)
(logand (collect-numbers xs) (lognot (collect-numbers ys))))
; 本体
(fold
(lambda (zs cnt)
(let ((a (filter space? zs)))
(if (null? a)
cnt ; 空き場所なし
(let* ((gs (filter space? (get-g-cell (get-g (car a))))) ; 枠の空き場所
(b (lset-difference eqv? (filter space? xs) a))
(c (lset-difference eqv? gs a)))
(intersection-flag-clear!
(number-difference a b)
(intersection-flag-clear! (number-difference a c) cnt b)
c)))))
0
(group xs 3)))
; 縦方向
(define (intersection-x)
(fold
(lambda (x a) (+ (intersection-sub (get-x-cell x)) a))
0
'(0 1 2 3 4 5 6 7 8)))
; 横方向
(define (intersection-y)
(fold
(lambda (x a) (+ (intersection-sub (get-y-cell x)) a))
0
'(0 1 2 3 4 5 6 7 8)))
;;
;; Enclosure
;;
; 組み合わせの生成
(define (combinations n ls)
(define (comb n ls a b)
(cond ((zero? n)
(cons (reverse a) b))
((= (length ls) n)
(cons (append (reverse a) ls) b))
(else
(comb (- n 1)
(cdr ls)
(cons (car ls) a)
(comb n (cdr ls) a b)))))
;
(comb n ls '() '()))
; ベクタの畳み込み
(define (vector-fold f a v)
(define (iter i a)
(if (= (vector-length v) i)
a
(iter (+ i 1) (f i a (vector-ref v i)))))
(iter 0 a))
; ビットの畳み込み
(define (bit-fold func init n)
(let loop ((n n) (a init))
(if (<= n 0)
a
(let ((m (logand (- n) n)))
(loop (logxor n m) (func m a))))))
; 要素が一つのリストか
(define (single? ls)
(and (pair? ls) (null? (cdr ls))))
; 置くことができる数字が一つしかないマスを探す
(define (search-cell . failure)
(vector-fold
(lambda (k a n)
(if (positive? n)
a
(let ((m (get-flag k)))
(cond ((zero? m)
(if (null? failure)
(error "data error")
((car failure) #f)))
((= (logcount m) 1)
(decide-number! m k)
(+ a 1))
(else a)))))
0
*board*))
; 置くことができる数字を集める
(define (collect-numbers xs)
(fold (lambda (x a) (logior (get-flag x) a)) 0 xs))
; Enclosure のチェック
(define (enclosure-sub n ls failure)
(fold
(lambda (xs a)
(let* ((m (collect-numbers xs))
(c (logcount m)))
(cond ((< c n) (failure #f))
((= c n)
(+ a (delete-flag! m (lset-difference eqv? ls xs))))
(else a))))
0
(combinations n ls)))
; 縦、横、枠で Enclosure をチェックする
(define (enclosure getpos failure)
(fold
(lambda (i a)
(let ((ls (filter space? (getpos i))))
(let loop ((j (length ls)) (b a))
(if (zero? j)
b
(loop (- j 1) (+ (enclosure-sub j ls failure) b))))))
0
'(0 1 2 3 4 5 6 7 8)))
; Enclosure のチェックを繰り返し行う
(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-x)
(intersection-y)
))
#t
(loop))))))
;;
;; Negation
;;
; 空き場所を求める
(define (get-space)
(vector-fold
(lambda (i a n) (if (zero? n) (cons i a) a))
'()
*board*))
; 候補の数字が少ない順に並べる
(define (get-space-sort)
(map car
(sort (map (lambda (x) (cons x (logcount (get-flag x))))
(get-space))
(lambda (x y) (< (cdr x) (cdr y))))))
; 背理法
(define (negation1 ls)
(let ((save1 *board*) (save2 *flag*))
(call/cc
(lambda (break)
(for-each
(lambda (k)
(bit-for-each
(lambda (n)
(set! *board* (vector-copy save1))
(set! *flag* (vector-copy save2))
(delete-flag! n (list k))
(cond ((not (enclosure-loop))
(set! *board* save1)
(set! *flag* save2)
(decide-number! n k)
(break #t))
(else
(set! *board* save1)
(set! *flag* save2))))
(get-flag k)))
ls)
#f))))
(define (negation2 ls)
(let ((save1 *board*) (save2 *flag*) (result #f))
(call/cc
(lambda (break)
(for-each
(lambda (k)
(let ((a '()) (b '()))
(bit-for-each
(lambda (n)
(set! *board* (vector-copy save1))
(set! *flag* (vector-copy save2))
; 仮置きする
(decide-number! n k)
(if (enclosure-loop)
; 矛盾しない
(push! a n)
; 矛盾する
(push! b n)))
(get-flag k))
; 元に戻す
(set! *board* save1)
(set! *flag* save2)
(cond ((single? a)
; 決定
(decide-number! (car a) k)
(break #t))
((pair? b)
; 矛盾した数字のフラグを消す
(for-each (lambda (n) (delete-flag! n (list k))) b)
(set! result #t)))))
ls)
result))))
; 解けたか？
(define (finish?)
(define (iter i)
(cond ((>= i SIZE2) #t)
((space? i) #f)
(else (iter (+ i 1)))))
(iter 0))
; 解法
(define (solver1 qs)
(set! *board* (make-bit-board qs))
(init-flag)
(let loop ()
(cond ((not (enclosure-loop))
(error "data error"))
((finish?)
(print-bit-board))
((negation2 (get-space-sort))
(loop))
(else
(print "----- Give up! -----")
(print-bit-board)
(print "----- Backtrack -----")
(dfs)))))
; 表の初期化
; 最初に１回だけ実行する
(init-tbl)