パズル「数独 (ナンバープレース)」の続きです。今回は基本的な「確定サーチ」を実装して、プログラムの高速化に挑戦してみましょう。
関数 init-board で盤面とフラグを初期化したあと、空き場所に対して確定サーチを行います。確定サーチで注意する点は、確定できなかったマスでも、ほかのマスで数字が決定することで、確定できる場合があることです。したがって、一度だけ調べるのではなく、数字が確定したマスがある限り、何度でも調べなければいけません。プログラムは次のようになります。
リスト : 確定サーチ + バックトラック
;;; 確定できる数字を探す
(define (search-number board)
(when
(positive? (+ (search-cell board)
(search-x board)
(search-y board)
(search-g board)))
(search-number board)))
;;; 解けたか？
(define (finish? board)
(call/cc
(lambda (ret)
(do ((y 0 (+ y 1)))
((>= y SIZE) #t)
(do ((x 0 (+ x 1)))
((>= x SIZE))
(when
(zero? (number-get board y x))
(ret #f)))))))
;;; 解法
(define (solver2 board)
(search-number board)
(cond
((finish? board)
(display "kakutei\n")
(print-board board))
(else
(display "backtrack\n")
(solver board 0 0))))
確定サーチは関数 search-number で行います。関数 search-cell は置くことができる数字が一つしかないマス (セル) を探します。関数 search-x, search-y, search-g は、縦横枠の中で置くことができるマスが一つしかない数字を探します。返り値は確定した数字の個数です。確定した数字が一つでもあれば確定サーチを繰り返します。
確定サーチが終了したら、関数 finish? で問題が解けたかチェックします。finish? は 盤面 bodard に空き場所 (0) があれば #f を返します。空き場所が見つからなければ、確定サーチだけで解くことができました。print-board で盤面を出力します。
簡単な問題であれば、確定サーチだけで解くことができるでしょう。また、難しい問題でも、確定サーチだけで解ける場合もあります。確定サーチで解けない場合は、関数 solver を呼び出してバックトラックで解を求めます。
次は search-cell を作ります。
リスト : 置ける数字が一つしかないマスを探す
(define (search-cell board)
(do ((c 0)
(y 0 (+ y 1)))
((>= y SIZE) c)
(do ((x 0 (+ x 1)))
((>= x SIZE))
(when
(zero? (number-get board y x))
(let ((num (available-number y x)))
(when
(= (bit-count num) 1)
(number-set! board y x num)
(set! c (+ c 1))))))))
search-cell は簡単です。二重の do ループで盤面 board の空き場所 (0) を探します。available-number で置くことができる数字を変数 num にセットし、bit-count で数字の個数を求めます。それが 1 であれば、number-set! でマス (y, x) に num をセットして、変数 c の値を +1 します。
次は縦方向の確定サーチを行う関数 search-x を作ります。
リスト : 縦方向の確定サーチ
(define (search-x board)
(do ((c 0)
(x 0 (+ x 1)))
((>= x SIZE) c)
(bit-for-each
(lambda (m)
(let ((a '()))
(do ((y 0 (+ y 1)))
((>= y SIZE))
(set! a (add-same-number board y x m a)))
(set! c (check-singleton board a m c))))
(vector-ref *xflag* x))))
do ループで各列に対して確定サーチを行います。各列で置くことがができる数字は *xflag* から求めることができます。bit-for-each で数字 m を取り出し、次の do ループで m を置くことができるマスを探します。マスは変数 a のリストに格納します。
関数 add-same-number は、マス (y, x) に m を置くことができるならば、a にドット対 (y . x) を追加して返します。次に、関数 check-singleton で m を置く場所が一つであること確認します。そうであれば、そのマスに m をセットして、変数 c の値を +1 します。
関数 add-same-number と check-singleton は次のようになります。
リスト : add-same-number と check-singleton
(define (add-same-number board y x m a)
(cond
((zero? (number-get board y x))
(if (zero? (bitwise-and (available-number y x) m))
a
(cons (cons y x) a)))
(else a)))
(define (check-singleton board ls m c)
(cond
((null? (cdr ls))
(number-set! board (caar ls) (cdar ls) m)
(+ c 1))
(else c)))
add-same-number はマス (y, x) が空き場所であれば、available-number で置くことができる数字を求め、それと m の論理積を bitwise-and で計算します。その結果が 0 でなければ、(y, x) に m を置くことができるので、ドット対 (y . x) を a に追加して返します。それ以外の場合は a をそのまま返します。
check-singleton は引数のリスト ls の要素が一つしかないことをチェックします。そうであれば、数字 m を (car ls) のマスに書き込みます。そして、引数 c の値を +1 してかえします。そうでなければ c をそのまま返します。
横のチェック search-y は方向を変えただけです。枠のチェック search-g も、2 次元配列のチェックなので少々面倒ですが、考え方はまったく同じです。詳細はプログラムリスト１をお読みください。
それでは、実際に数独を解いてみましょう。deepgreen さんが作成された「ナンプレ問題集」より問題 9909-c1, 9909-d1, 9909-e1, 9909-h1, 9909-h2 を試してみたところ、実行時間は次のようになりました。
表 : 実行結果 (単位 : 秒) 問題 : Hint : (1) : (2) : (3) ------+------+-------+------+------------ c1 : 22 : 3.50 : 0.40 : 0.024 d1 : 21 : 17.25 : 1.79 : 0.003 (確) e1 : 24 : 3.07 : 0.32 : 0.002 h1 : 23 : 0.38 : 0.04 : 0.002 (確) h2 : 24 : 1.20 : 0.17 : 0.002 (確) 実行環境 : Gauche ver 0.9.9, Ubunts 18.04 (WSL), Intel Core i5-6200U 2.30GHz
(3) が確定サーチを行った結果です。(確) は確定サーチだけで解けたことを表します。結果を見ればおわかりのように、確定サーチの効果はとても高く、どの問題も高速に解くことできました。確定サーチを行うことにより、空き場所の数を減らすことができるので、バックトラックで解を求める場合でも高速に解くことができます。
ただし、どのような問題でも高速に解けるわけではありません。下記 URL に掲載されているフィンランドの数学者 Arto Inkala さんが作成された問題は、確定サーチで数字を決定できる空き場所がほとんどありません。
ご参考までに実行時間を示します。
表 : 実行結果 (単位 : 秒) 問題 : Hint : (2) : (3) ------+------+------+------ １ : 23 : 0.14 : 0.13 ２ : 21 : 3.66 : 3.69
このように、基本的な確定サーチだけでは高速化に限界があるようです。
参考文献『あらゆる数独パズルを解く』によると、候補となる数字が最小のマスから試行していくと、実行時間が速くなるそうです。どれくらい速くなるのか、実際に試してみました。次のリストを見てください。
リスト : 候補となる数字の少ないマスから調べる
(define (search-min-cell board)
(call/cc
(lambda (ret)
(let ((m 10) (pos #f))
(do ((y 0 (+ y 1)))
((>= y SIZE) pos)
(do ((x 0 (+ x 1)))
((>= x SIZE))
(when
(zero? (number-get board y x))
(let ((c (bit-count (available-number y x))))
(cond
((zero? c)
(ret (cons y x)))
((< c m)
(set! m c)
(set! pos (cons y x))))))))))))
関数 search-min-cell は、候補の数字が最小となるマスを返します。二重の do ループで board の要素を順番に取り出して、マス (y, x) が空き場所であれば、available-number で候補の数字を求め、bit-count で数字の個数を数えて変数 c にセットします。
c が 0 の場合、継続 ret を評価してマスの位置を返すことに注意してください。この場合、解はないのですぐにバックトラックしたほうが効率的です。今までの探索ではマスを順番に調べていくので、数字の候補がなくなったマスをすぐに検出することができませんでした。つまり、無駄な探索が行われていたわけです。
たとえば、最初に調べるマスに数字の候補が 2 つある場合、最初の数字を選んで探索を行い、候補の数字が 0 となるマスが見つかれば、その時点で探索する局面数を 1 / 2 に減らすことができます。試行する順番だけではなく、数字の候補が 0 となるマスを素早く見つけることも高速化の重要なポイントになります。
c が変数 m より小さい場合は、マス (y, x) を変数 pos に、c を変数 m にセットします。あとは探索を続行して、最後にマスの位置 pos を返します。pos は #f に初期化されているので、空き場所が見つからない場合は #f を返すことになります。
次は search-min-cell を用いて深さ優先探索を行う関数 solver3 と solver4 を作ります。
リスト : 深さ優先探索
(define (solver3 board)
(let ((pos (search-min-cell board)))
(if (not pos)
(print-board board)
(let ((y (car pos)) (x (cdr pos)))
(bit-for-each
(lambda (num)
(number-set! board y x num)
(solver3 board)
(number-del! board y x num))
(available-number y x))))))
(define (solver4 board)
(search-number board)
(cond
((finish? board)
(display "kakutei\n")
(print-board board))
(else
(display "backtrack\n")
(solver3 board))))
solver3 は簡単です。最初に search-min-cell で数字が最小の候補数のマスを求めます。pos が #f の場合、空き場所が見つからない、つまり、解を求めることができました。print-board で盤面を表示します。そうでなければ、available-number で候補の数字を求め、bit-for-each で数字を順番に試していきます。数字の候補が無い場合はすぐにバックトラックすることに注意してください。solver4 は最初に確定サーチを行い、解けない場合は solver3 を呼び出します。
それでは実行してみましょう。
表 : 実行結果 (単位 : 秒) 問題 : Hint : (2) : (2a) : (3) | (3a) ------+------+------+-------+-------+------- c1 : 22 : 0.40 : 0.21 : 0.024 : 0.013 d1 : 21 : 1.79 : 0.39 : 0.003 : (確) e1 : 24 : 0.32 : 0.003 : 0.002 : 0.003 h1 : 23 : 0.04 : 0.003 : 0.002 : (確) h2 : 24 : 0.17 : 0.05 : 0.002 : (確) 問題 : Hint : (2) : (2a) : (3) | (3a) ------+------+------+-------+------+------- １ : 23 : 0.14 : 0.036 : 0.13 : 0.035 ２ : 21 : 3.66 : 0.42 : 3.69 : 0.43 (2a) solver3 の実行結果 (3a) solver4 の実行結果 実行環境 : Gauche ver 0.9.9, Ubunts 18.04 (WSL), Intel Core i5-6200U 2.30GHz
(2) と (2a) では、どの問題も (2a) のほうが速くなりました。改良の効果は十分に出ていると思います。(3) と (3a) では、(3a) のほうがわずかに遅くなる場合もありました。確定サーチである程度マスが埋まると、数字の候補数が少ない状態になるので、search-min-cell を用いなくても高速に解けるのでしょう。興味のある方はいろいろ試してみてください。
;;;
;;; numplace3.scm : ナンバープレース (確定サーチ)
;;;
;;; Copyright (C) 2010-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write) (scheme time)
(scheme bitwise))
;;; 大域変数
(define SIZE 9)
(define *xflag* #f)
(define *yflag* #f)
(define *gflag* #f)
;;; 枠の番号
(define (group-number y x)
(+ (quotient x 3) (* (quotient y 3) 3)))
;;; フラグを反転する
(define (rev-flag y x m)
(let ((z (group-number y x)))
(vector-set! *xflag* x (bitwise-xor (vector-ref *xflag* x) m))
(vector-set! *yflag* y (bitwise-xor (vector-ref *yflag* y) m))
(vector-set! *gflag* z (bitwise-xor (vector-ref *gflag* z) m))))
;;; 使用可能な数字をビットで求める
(define (available-number y x)
(bitwise-and (vector-ref *xflag* x)
(vector-ref *yflag* y)
(vector-ref *gflag* (group-number y x))))
;;; 数字を得る
(define (number-get board y x)
(vector-ref (vector-ref board y) x))
;;; 数字を置く
(define (number-set! board y x num)
(vector-set! (vector-ref board y) x num)
(rev-flag y x num))
;;; 数字を消す
(define (number-del! board y x num)
(vector-set! (vector-ref board y) x 0)
(rev-flag y x num))
;;; 初期化
(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 (init-board xss)
(let ((board (make-board xss)))
(set! *xflag* (make-vector SIZE #b1111111110))
(set! *yflag* (make-vector SIZE #b1111111110))
(set! *gflag* (make-vector SIZE #b1111111110))
(do ((y 0 (+ y 1)))
((>= y SIZE) board)
(do ((x 0 (+ x 1)))
((>= x SIZE))
(let ((num (number-get board y x)))
(unless
(zero? num)
(rev-flag y x num)))))))
;;; 盤面の表示
(define (print-board 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 board y x)
(cond
((= y SIZE)
(print-board board))
((= x SIZE)
(solver board (+ y 1) 0))
((zero? (number-get board y x))
(bit-for-each
(lambda (num)
(number-set! board y x num)
(solver board y (+ x 1))
(number-del! board y x num))
(available-number y x)))
(else
(solver board y (+ x 1)))))
;;;
;;; 確定サーチ
;;;
;;;
(define (search-cell board)
(do ((c 0)
(y 0 (+ y 1)))
((>= y SIZE) c)
(do ((x 0 (+ x 1)))
((>= x SIZE))
(when
(zero? (number-get board y x))
(let ((num (available-number y x)))
(when
(= (bit-count num) 1)
(number-set! board y x num)
(set! c (+ c 1))))))))
(define (add-same-number board y x m a)
(cond
((zero? (number-get board y x))
(if (zero? (bitwise-and (available-number y x) m))
a
(cons (cons y x) a)))
(else a)))
(define (check-singleton board ls m c)
(cond
((null? (cdr ls))
(number-set! board (caar ls) (cdar ls) m)
(+ c 1))
(else c)))
(define (search-x board)
(do ((c 0)
(x 0 (+ x 1)))
((>= x SIZE) c)
(bit-for-each
(lambda (m)
(let ((a '()))
(do ((y 0 (+ y 1)))
((>= y SIZE))
(set! a (add-same-number board y x m a)))
(set! c (check-singleton board a m c))))
(vector-ref *xflag* x))))
(define (search-y board)
(do ((c 0)
(y 0 (+ y 1)))
((>= y SIZE) c)
(bit-for-each
(lambda (m)
(let ((a '()))
(do ((x 0 (+ x 1)))
((>= x SIZE))
(set! a (add-same-number board y x m a)))
(set! c (check-singleton board a m c))))
(vector-ref *yflag* y))))
(define (search-g board)
(do ((c 0)
(y 0 (+ y 3)))
((> y 6) c)
(do ((x 0 (+ x 3)))
((> x 6))
(bit-for-each
(lambda (m)
(let ((a '()))
(do ((i 0 (+ i 1)))
((> i 2))
(do ((j 0 (+ j 1)))
((> j 2))
(set! a (add-same-number board (+ y i) (+ x j) m a))))
(set! c (check-singleton board a m c))))
(vector-ref *gflag* (group-number y x))))))
;;; 確定できる数字を探す
(define (search-number board)
(when
(positive? (+ (search-cell board)
(search-x board)
(search-y board)
(search-g board)))
(display "search\n")
(search-number board)))
;;; 解けたか？
(define (finish? board)
(call/cc
(lambda (ret)
(do ((y 0 (+ y 1)))
((>= y SIZE) #t)
(do ((x 0 (+ x 1)))
((>= x SIZE))
(when
(zero? (number-get board y x))
(ret #f)))))))
;;; 解法
(define (solver2 board)
(search-number board)
(cond
((finish? board)
(display "kakutei\n")
(print-board board))
(else
(display "backtrack\n")
(solver board 0 0))))
;;; 候補となる数字の少ないマスから調べる
(define (search-min-cell board)
(call/cc
(lambda (ret)
(let ((m 10) (pos #f))
(do ((y 0 (+ y 1)))
((>= y SIZE) pos)
(do ((x 0 (+ x 1)))
((>= x SIZE))
(when
(zero? (number-get board y x))
(let ((c (bit-count (available-number y x))))
(cond
((zero? c)
(ret (cons y x)))
((< c m)
(set! m c)
(set! pos (cons y x))))))))))))
;;; 解法
(define (solver3 board)
(let ((pos (search-min-cell board)))
(if (not pos)
(print-board board)
(let ((y (car pos)) (x (cdr pos)))
(bit-for-each
(lambda (num)
(number-set! board y x num)
(solver3 board)
(number-del! board y x num))
(available-number y x))))))
(define (solver4 board)
(search-number board)
(cond
((finish? board)
(display "kakutei\n")
(print-board board))
(else
(display "backtrack\n")
(solver3 board))))
「ラテン方陣」は数独の枠の条件を無くした方陣です。ラテン方陣の定義を参考文献『数理パズルのはなし』より引用します。
『ラテン方陣を一般的にいうなら、n 行 n 列の正方形の枡に n 種類の記号を n 個ずつ配列して、各行各列に記号の重複のないものを n 次のラテン方陣というのです。』このラテン方陣をパズルに応用したものが数独というわけです。
簡単な例を示しましょう。3 次のラテン方陣は次に示す 12 通りになります。
1 2 3 1 2 3 1 3 2 1 3 2 2 1 3 2 1 3
2 3 1 3 1 2 2 1 3 3 2 1 1 3 2 3 2 1
3 1 2 2 3 1 3 2 1 2 1 3 3 2 1 1 3 2
標準形
2 3 1 2 3 1 3 1 2 3 1 2 3 2 1 3 2 1
1 2 3 3 1 2 1 2 3 2 3 1 1 3 2 2 1 3
3 1 2 1 2 3 2 3 1 1 2 3 2 1 3 1 3 2
図 : 3 次のラテン方陣
この中で、最初の行と列の要素を昇順に並べたものを「標準形」といいます。3 次のラテン方陣の場合、標準形は 1 種類しかありません。ラテン方陣は任意の行を交換する、または任意の列を交換してもラテン方陣になります。3 次のラテン方陣の場合、標準形から行または列を交換することで、残りの 11 種類のラテン方陣を生成することができます。
参考文献 [1] によると、n 次のラテン方陣の総数は標準形の個数を In とすると、次の式で表すことができます。
n! * (n - 1)! * In
ちなみに、In の値は n が増えると急激に増加します。参考文献 [1] より引用します。
I3 = 1 I4 = 4 I5 = 56 I6 = 9408 I7 = 16942080 I8 = 535281401856 I9 = 377597570964258816
n 次の標準形ラテン方陣を生成するプログラムは、数独の解法プログラムを改造することで簡単に作成することができます。プログラムの説明は割愛するので、興味のある方はプログラムリスト２をお読みください。
なお、高次の標準形ラテン方陣の総数は、簡単に求めることができない非常にハードな問題です。今回のプログラムで I7 の総数を求めようとしたのですが、筆者の貧弱な実行環境ではいつまでたっても終わらないので途中であきらめました。
プログラムの中でラテン方陣を生成する関数が latin です。
latin func size
latin は高階関数です。size 次の標準形ラテン方陣を生成し、それを引数の関数 func に渡します。簡単な実行例を示しましょう。
gosh[r7rs.user]> (latin print-board 3) 1 2 3 2 3 1 3 1 2 #<undef> gosh[r7rs.user]> (latin print-board 4) 1 2 3 4 2 1 4 3 3 4 1 2 4 3 2 1 1 2 3 4 2 1 4 3 3 4 2 1 4 3 1 2 1 2 3 4 2 3 4 1 3 4 1 2 4 1 2 3 1 2 3 4 2 4 1 3 3 1 4 2 4 3 2 1 #<undef>
5 次、6 次のラテン方陣の個数を求めると次のようになります。
gosh[r7rs.user]> (let ((c 0)) (latin (lambda (x) (set! c (+ c 1))) 5) c) 56 gosh[r7rs.user]> (let ((c 0)) (latin (lambda (x) (set! c (+ c 1))) 6) c) 9408
ちなみに、5 次、6 次、7 次で最初に出力されるラテン方陣は次のようになります。
gosh[r7rs.user]> (call/cc (lambda (break) (latin (lambda (x) (print-board x) (break #t)) 5))) 1 2 3 4 5 2 1 4 5 3 3 4 5 1 2 4 5 2 3 1 5 3 1 2 4 #t gosh[r7rs.user]> (call/cc (lambda (break) (latin (lambda (x) (print-board x) (break #t)) 6))) 1 2 3 4 5 6 2 1 4 3 6 5 3 4 5 6 1 2 4 3 6 5 2 1 5 6 1 2 3 4 6 5 2 1 4 3 #t gosh[r7rs.user]> (call/cc (lambda (break) (latin (lambda (x) (print-board x) (break #t)) 7))) 1 2 3 4 5 6 7 2 1 4 3 6 7 5 3 4 1 2 7 5 6 4 5 6 7 1 2 3 5 3 7 6 2 1 4 6 7 2 5 3 4 1 7 6 5 1 4 3 2 #t
;;;
;;; latin.scm : ラテン方陣
;;;
;;; Copyright (C) 2010-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write) (scheme time)
(scheme bitwise))
;;; 大域変数
(define *xflag* #f)
(define *yflag* #f)
;;; フラグを反転する
(define (rev-flag y x m)
(vector-set! *xflag* x (bitwise-xor (vector-ref *xflag* x) m))
(vector-set! *yflag* y (bitwise-xor (vector-ref *yflag* y) m)))
;;; 使用可能な数字をビットで求める
(define (available-number y x)
(bitwise-and (vector-ref *xflag* x) (vector-ref *yflag* y)))
;;; 数字を得る
(define (number-get board y x)
(vector-ref (vector-ref board y) x))
;;; 数字を置く
(define (number-set! board y x num)
(vector-set! (vector-ref board y) x num)
(rev-flag y x num))
;;; 数字を消す
(define (number-del! board y x num)
(vector-set! (vector-ref board y) x 0)
(rev-flag y x num))
;;; 初期化
(define (make-board size)
(let ((board (make-vector size)))
(do ((i 0 (+ i 1)))
((>= i size) board)
(vector-set! board i (make-vector size 0)))))
(define (init-board size)
(let ((board (make-board size)))
(set! *xflag* (make-vector size (- (expt 2 (+ size 1)) 2)))
(set! *yflag* (make-vector size (- (expt 2 (+ size 1)) 2)))
(do ((x 0 (+ x 1)))
((>= x size))
(number-set! board 0 x (arithmetic-shift 1 (+ x 1))))
(do ((y 1 (+ y 1)))
((>= y size) board)
(number-set! board y 0 (arithmetic-shift 1 (+ y 1))))))
;;; 盤面の表示
(define (print-board board)
(vector-for-each
(lambda (xs)
(vector-for-each
(lambda (x) (display (bit-count (- x 1))) (display " "))
xs)
(newline))
board)
(newline))
;;; ビット用高階関数
(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 proc board y x)
(cond
((= y (vector-length board))
(proc board))
((= x (vector-length board))
(solver proc board (+ y 1) 0))
((zero? (number-get board y x))
(bit-for-each
(lambda (num)
(number-set! board y x num)
(solver proc board y (+ x 1))
(number-del! board y x num))
(available-number y x)))
(else
(solver proc board y (+ x 1)))))
(define (latin func size)
(solver func (init-board size) 1 1))