それではプログラムを作りましょう。今回は パズルの解法 [3] で取り上げたペグ・ソリティア Hoppers と同様に、ペグの有無をビット (0 or 1) で表し、最短手順を反復深化で求めることにします。ただし、単純な反復進化では時間がかかるので「下限値枝刈り法」を使います。
最初に、ペグの跳び先表を定義します。下図のように穴に番号をつけると、跳び先表は次のようになります。
０─１─２
│×│×│
３─４─５─６─７
│×│×│×│×│
８─９─10─11─12
│×│×│×│×│
13─14─15─16─17
│×│×│
18─19─20
図 : 21 穴盤
リスト : 跳び先表
(define *jump-table*
#(((1 2) (4 9) (5 11)) ; 0
((4 8) (5 10) (6 12)) ; 1
((1 0) (5 9) (6 11)) ; 2
((4 5) (8 13) (9 15)) ; 3
((5 6) (9 14) (10 16)) ; 4
((4 3) (6 7) (9 13) (10 15) (11 17)) ; 5
((5 4) (10 14) (11 16)) ; 6
((6 5) (11 15) (12 17)) ; 7
((4 1) (9 10) (14 19)) ; 8
((4 0) (5 2) (10 11) (14 18) (15 20)) ; 9
((5 1) (9 8) (11 12) (15 19)) ; 10
((5 0) (6 2) (10 9) (15 18) (16 20)) ; 11
((6 1) (11 10) (16 19)) ; 12
((8 3) (9 5) (14 15)) ; 13
((9 4) (10 6) (15 16)) ; 14
((9 3) (10 5) (11 7) (14 13) (16 17)) ; 15
((10 4) (11 6) (15 14)) ; 16
((11 5) (12 7) (16 15)) ; 17
((14 9) (15 11) (19 20)) ; 18
((14 8) (15 10) (16 12)) ; 19
((15 9) (16 11) (19 18)))) ; 20
データは跳び越す位置と着地する位置の 2 個 1 セットで表しています。たとえば、0 番のペグは 1 番を跳び越して 2 番に着地するという跳び方があります。
次は下限値の求め方を考えてみましょう。ペグ・ソリテアの場合、コーナーにあるペグはほかのペグから跳び越されることはありません。つまり、コーナーのペグは自分でジャンプするしか移動する方法がないのです。したがって、コーナーにペグが残っていれば、最低でもその個数だけ移動手数が必要になります。今回の場合、コーナーは 0, 2, 3, 7, 13, 17, 18, 20 番の 8 か所あります。これを下限値として利用することができます。
下限値を求めるプログラムは次のようになります。
リスト : 下限値を求める
(define (get-lower-value board)
(fold (lambda (x a) (if (logbit? x board) (+ a 1) a))
0
'(0 2 3 7 13 17 18 20)))
fold でコーナーペグの個数を数えているだけです。今回はこれでいいのですが、中央補償型以外の解を求める場合は修正が必要になります。たとえば、最終手でコーナーに移動できるペグが連続跳びする場合、ペグがコーナーに着地した時に下限値を +1 すると、その手順が枝狩りされてしまいます。連続跳びしているペグの場合は、コーナーに着地しても下限値を +1 しないように修正してください。
次はビット用の高階関数を定義します。
リスト : ビット用高階関数
(define (bit-for-each-with-index proc n size)
(let loop ((x 0) (n n))
(cond ((< x size)
(proc x (logand n 1))
(loop (+ x 1) (ash n -1))))))
bit-for-each-with-index は vector-for-each-with-index のビット版です。引数の関数 proc にはビットの位置と値 (0 or 1) を渡します。簡単な使用例を示しましょう。
gosh> (bit-for-each-with-index (lambda (n x) (format #t "~D, ~D~%" n x)) #xeeee 16) 0, 0 1, 1 2, 1 3, 1 4, 0 5, 1 6, 1 7, 1 8, 0 9, 1 10, 1 11, 1 12, 0 13, 1 14, 1 15, 1 #<undef>
次は反復深化で最短手順を求める関数 id-search を作ります。
リスト : 反復深化による解法
(define (id-search board jc limit move found)
(if (<= (+ jc (get-lower-value board)) limit)
(if (= (length move) MAX-JUMP)
(if (= board #b10000000000)
(begin (print-answer (reverse move))
(found #t)))
(bit-for-each-with-index
(lambda (from peg)
(if (positive? peg)
(for-each
(lambda (pos)
(if (and (logbit? (car pos) board)
(not (logbit? (cadr pos) board)))
(id-search
(move-peg board from (car pos) (cadr pos))
(if (= from (cdar move))
jc
(+ jc 1))
limit
(cons (cons from (cadr pos)) move)
found)))
(vector-ref *jump-table* from))))
board SIZE))))
引数 board が盤面を表す整数値、jc がペグが跳んだ回数、limit が反復深化の上限値、move が移動手順を格納するリストです。move の要素はドット対 (form . to) です。引数 found は脱出用の継続です。今回は手順をひとつ見つけたら探索を終了します。
ペグ・ソリテアを反復深化で解く場合、上限値 limit に達していても連続跳びによりペグを移動できることに注意してください。最初に、(+ jc (get-lower-value board)) を計算して limit 以下であればペグを移動します。これで下限値枝刈り法が有効になります。
21 穴盤の場合、ペグの総数は 20 個なので、MAX-JUMP (19) 回ペグを移動すると残りのペグは 1 個になります。それが 10 番の位置にあれば最短手順を見つけることができました。関数 print-answer で手順を表示して、継続 found を評価して探索を終了します。
あとは特に難しいところはないと思います。説明は割愛するので、詳細は プログラムリスト３ をお読みください。
実行結果を示します。
----- 8 ----- ----- 9 ----- ----- 10 ----- [1,10] [13,5] [2,9] [17,5] [18,11] [3,15] [20,9] [7,15,3,13,15] [0,11,18,20,11,9] [12,1,8,10]
最短手数は 10 手になりました。
;
; peg21.scm : ペグソリティアの解法
;
; Copyright (C) 2010 Makoto Hiroi
;
; 跳び先表
(define *jump-table*
#(((1 2) (4 9) (5 11)) ; 0
((4 8) (5 10) (6 12)) ; 1
((1 0) (5 9) (6 11)) ; 2
((4 5) (8 13) (9 15)) ; 3
((5 6) (9 14) (10 16)) ; 4
((4 3) (6 7) (9 13) (10 15) (11 17)) ; 5
((5 4) (10 14) (11 16)) ; 6
((6 5) (11 15) (12 17)) ; 7
((4 1) (9 10) (14 19)) ; 8
((4 0) (5 2) (10 11) (14 18) (15 20)) ; 9
((5 1) (9 8) (11 12) (15 19)) ; 10
((5 0) (6 2) (10 9) (15 18) (16 20)) ; 11
((6 1) (11 10) (16 19)) ; 12
((8 3) (9 5) (14 15)) ; 13
((9 4) (10 6) (15 16)) ; 14
((9 3) (10 5) (11 7) (14 13) (16 17)) ; 15
((10 4) (11 6) (15 14)) ; 16
((11 5) (12 7) (16 15)) ; 17
((14 9) (15 11) (19 20)) ; 18
((14 8) (15 10) (16 12)) ; 19
((15 9) (16 11) (19 18)))) ; 20
; 定数
(define MAX-JUMP 19)
(define SIZE 21)
; ビット用高階関数
(define (bit-for-each-with-index proc n size)
(let loop ((x 0) (n n))
(cond ((< x size)
(proc x (logand n 1))
(loop (+ x 1) (ash n -1))))))
; 下限値を求める
(define (get-lower-value board)
(fold (lambda (x a) (if (logbit? x board) (+ a 1) a))
0
'(0 2 3 7 13 17 18 20)))
; ペグの移動
(define (move-peg board from del to)
(logior
(logand board
(lognot (ash 1 from))
(lognot (ash 1 del)))
(ash 1 to)))
; 手順の表示
(define (print-answer move)
(let ((prev (cdar move)))
; 初手を表示
(format #t "[~D,~D" (caar move) prev)
; 2 手目以降を表示する
(for-each
(lambda (x)
(cond ((= prev (car x))
; 同じ駒が続けて跳ぶ
(set! prev (cdr x))
(format #t ",~D" prev))
(else
(set! prev (cdr x))
(format #t "]~%[~D,~D" (car x) prev))))
(cdr move))
(format #t "]~%~%")))
; 反復深化による解法
(define (id-search board jc limit move found)
(if (<= (+ jc (get-lower-value board)) limit)
(if (= (length move) MAX-JUMP)
(if (= board #b10000000000)
(begin (print-answer (reverse move))
(found #t)))
(bit-for-each-with-index
(lambda (from peg)
(if (positive? peg)
(for-each
(lambda (pos)
(if (and (logbit? (car pos) board)
(not (logbit? (cadr pos) board)))
(id-search
(move-peg board from (car pos) (cadr pos))
(if (= from (cdar move))
jc
(+ jc 1))
limit
(cons (cons from (cadr pos)) move)
found)))
(vector-ref *jump-table* from))))
board SIZE))))
;
(define (solve start)
(call/cc
(lambda (break)
(let loop ((i 8))
(cond ((<= i MAX-JUMP)
(format #t "----- ~D -----~%" i)
; 初手を 1 -> 10 に限定
(id-search (move-peg start 1 5 10) 1 i '((1 . 10)) break)
(loop (+ i 1))))))))
; 実行
(solve #b111111111101111111111)
それではプログラムを作りましょう。８めくりはライトオン・オフの 2 種類の状態しかないので、盤面はリストよりも整数値で表したほうが簡単です。オン・オフの状態を 1 と 0 で表し、各ビットとボタンの番号を対応させると、盤面は 0 から 65535 の整数値で表すことができます。
□□□□ ０ １ ２ ３ □□□□ ４ ５ ６ ７ □□□□ ８ ９ 10 11 □□□□ 12 13 14 15 図 : ボタンの番号
ボタンを押してライトの状態を反転する処理も簡単です。たとえば、ボタン 5 を押した場合、0, 1, 2, 4, 6, 8, 9, 10 のライトを反転させます。この場合、8 つのボタンのビットをオンにした値 #b11101010111 と、盤面を表す整数値の排他的論理和 (xor) を求めれば、8 つのライトの状態を反転することができます。次の例を見てください。
0 xor #b11101010111 => #b11101010111 % 消灯の状態でボタン 5 を押す
#b11101010111 xor #b11101010111 => 0 % もう一度同じボタンを押す
このように、８めくりは同じボタンを二度押すと元の状態に戻ります。したがって、同じボタンは二度押さなくてよいことがわかります。また、実際にボタンを押してみるとわかりますが、ボタンを押す順番は関係がないことがわかります。たとえば、ボタン 0 と 1 を押す場合、0 -> 1 と押すのも 1 -> 0 と押すのも同じ結果になります。これはライツアウトとまったく同じです。
この 2 つの法則から、ボタンを押す組み合わせは全部で 2 ^ 16 通りになります。８めくりを解くいちばん単純な方法は、ボタンを押す組み合わせを生成して、実際にライトが全部消えるかチェックすることです。今回は小さい盤なので、単純な方法で解いてみましょう。ただし、この方法は盤面が大きくなると時間がかかります。ご注意ください。
プログラムは次のようになります。
リスト : ８めくりの解法
(define (solve n m)
; 反転パターン
(define pattern (make-pattern n m))
; 盤面の生成
(define (make-new-board board xs)
(fold (lambda (x a) (logxor (vector-ref pattern x) a))
board
xs))
; 盤の大きさ
(define size (* n m))
(define all (- (expt 2 size) 1))
; 解の総数
(define found 0)
;
(let loop ((x 1))
(cond ((and (zero? found) (<= x size))
(combinations
(lambda (xs)
(if (zero? (make-new-board all xs))
(begin (inc! found)
(print xs))))
x
(iota size))
(loop (+ x 1))))))
関数 solve は n 行 m 列盤の「８めくり」の最短手数を求めます。ボタンを押したときの反転パターンは関数 make-pattern で作成します。返り値はベクタで、変数 pattern にセットします。関数 make-new-board は複数のボタンを押して新しい盤面を生成します。引数 xs はボタンの番号を格納したリストです。新しい盤面は fold を使うと簡単に求めることができます。
あとは、押すボタンの個数を一つずつ増やしていき、全てのボタンが消灯するかチェックするだけです。押すボタンの組み合わせは関数 combinations で求めます。この関数は拙作のページ 順列と組み合わせ で作成したものです。iota は数列を生成する関数で、ライブラリ SRFI-1 に定義されています。拙作のページ 便利なリスト操作関数 でも取り上げているので、興味のある方はお読みください。
あとはとくに難しいところはないと思います。説明は割愛するので、詳細は プログラムリスト４ をお読みください。
実行結果は次のようになりました。
(0 2 5 9 12 14) (0 3 5 6 8 11) (1 3 6 10 13 15) (4 7 9 10 12 15)
最短手数は 6 手で、4 通りの手順が出力されました。これを図に示すと次のようになります。
○・○・ ○・・○ ・○・○ ・・・・
・○・・ ・○○・ ・・○・ ○・・○
・○・・ ○・・○ ・・○・ ・○○・
○・○・ ・・・・ ・○・○ ○・・○
図 : ８めくり (4 * 4 盤) の解答
ところで、最長手数を幅優先探索 (関数 solve-max) で求めたところ、結果は次のようになりました。
1 move: 16 2 move: 120 3 move: 560 4 move: 1387 5 move: 1440 6 move: 540 7 move: 32 8 move: 0 9 move: 0 10 move: 0 11 move: 0 12 move: 0 13 move: 0 14 move: 0 15 move: 0 16 move: 0
最長手数は 7 手で、局面の総数は全部のボタンが消灯した状態を含めて 4096 通りになりました。全局面の 1 / 16 しかありません。ただし、この結果は盤面の大きさにより変化するので注意してください。
たとえば 4 * 6 盤の場合、最長手数は 24 手で、全局面数は 2 ^ 24 = 16777216 通りになります。また 5 * 5 盤の場合、全てのボタンが点灯した状態から GOAL (全ボタン消灯) に到達することはできません。GOAL に到達できる局面は 2 ^ 25 / 2 = 16777216 通りあり、その中で最長手数は 20 手 (126 通り) になります。
なお、８めくりはライツアウトと同様に連立方程式を使うと大きな盤面でも高速に解くことができます。deepgreen さんの Web サイト Computer Puzzle Solution で、詳しい説明とその結果が公開されています。興味のある方はぜひお読みくださいませ。
;
; eight.scm : 8 めくり
;
; Copyright (C) 2010 Makoto Hiroi
;
(use srfi-1)
; パターンの生成
(define (make-pattern n m)
(let* ((size (* n m))
(pattern (make-vector size)))
(let loop ((i 0))
(cond ((< i size)
(let ((x (modulo i m))
(y (quotient i m)))
(vector-set! pattern i
(fold (lambda (z a)
(let ((x1 (+ x (car z)))
(y1 (+ y (cdr z))))
(if (and (< -1 x1 m) (< -1 y1 n))
(logior a (ash 1 (+ (* m y1) x1)))
a)))
0
'((-1 . -1) (0 . -1) (1 . -1) (-1 . 0)
(1 . 0) (-1 . 1) (0 . 1) (1 . 1)))))
(loop (+ i 1)))
(else pattern)))))
; 組み合わせの生成
(define (combinations func n ls)
(define (comb n ls a)
(cond ((zero? n)
(func (reverse a)))
((= (length ls) n)
(func (append (reverse a) ls)))
(else
(comb (- n 1) (cdr ls) (cons (car ls) a))
(comb n (cdr ls) a))))
(if (> n (length ls))
#f
(comb n ls '())))
; 解法
(define (solve n m)
; 反転パターン
(define pattern (make-pattern n m))
; 盤面の生成
(define (make-new-board board xs)
(fold (lambda (x a) (logxor (vector-ref pattern x) a))
board
xs))
; 盤の大きさ
(define size (* n m))
(define all (- (expt 2 size) 1))
; 解の総数
(define found 0)
;
(let loop ((x 1))
(cond ((and (zero? found) (<= x size))
(combinations
(lambda (xs)
(if (zero? (make-new-board all xs))
(begin (inc! found)
(print xs))))
x
(iota size))
(loop (+ x 1))))))
;;;
;;; 最長手数の探索
;;;
(define (solve-max n m)
; 反転パターン
(define pattern (make-pattern n m))
; 盤面の生成
(define (make-new-board board xs)
(fold (lambda (x a) (logxor (vector-ref pattern x) a))
board
xs))
; 盤の大きさ
(define size (* n m))
;
(let ((table (make-vector (expt 2 size) #f)))
(vector-set! table 0 #t)
(let loop ((x 1))
(let ((cnt 0))
(cond ((<= x size)
(combinations
(lambda (xs)
(let ((board (make-new-board 0 xs)))
(if (not (vector-ref table board))
(begin (inc! cnt)
(vector-set! table board #t)))))
x
(iota size))
(format #t "~D move: ~D~%" x cnt)
(loop (+ x 1))))))))
; 実行
(solve 4 4)
(solve-max 4 4)
今回は「幅優先探索」でプログラムを作りましょう。9 種類の駒があるので、局面の総数は 9! = 362880 通りあります。同一局面のチェックに線形探索を使うと時間がかかるので Gauche のハッシュ表を使うことにします。
盤面はベクタで表します。盤面の位置を下図のように表すと、駒をスライドして新しい盤面を生成するプログラムは次のようになります。
┌─┬─┬─┐
│０│１│２│
├─┼─┼─┤
│３│４│５│
├─┼─┼─┤
│６│７│８│
└─┴─┴─┘
図 : スライドパズルの盤面
リスト : 新しい盤面を生成する
; スライドパターン
(define *slide-pattern*
'((8 4 0) (6 4 2) (7 4 1) (5 4 3)
(0 4 8) (2 4 6) (1 4 7) (3 4 5)))
; 盤面の生成
(define (make-new-board board ls)
(let ((new-board (vector-copy board)))
(vector-set! new-board (car ls) (vector-ref board (cadr ls)))
(vector-set! new-board (cadr ls) (vector-ref board (caddr ls)))
(vector-set! new-board (caddr ls) (vector-ref board (car ls)))
new-board))
スライドする 8 方向をリストで定義します。リストが (x y z) とすると、x 番目の駒を z 番目に、y 番目の駒を x 番目に、z 番目の駒を y 番目に移動します。この処理を関数 make-new-board で行います。あとは単純な幅優先探索です。プログラムは次のようになります。
リスト : 幅優先探索
(define (solve start goal)
(define ht (make-hash-table 'equal?))
;
(hash-table-put! ht start #t)
(enqueue! (cons start '()))
(call/cc
(lambda (break)
(let loop ()
(cond ((< rp wp)
(let ((state (dequeue!)))
(for-each
(lambda (pat)
(let ((new-board (make-new-board (car state) pat)))
(cond ((equal? new-board goal)
(print-answer (cons new-board state))
(break #t))
((not (hash-table-get ht new-board #f))
(hash-table-put! ht new-board #t)
(enqueue! (cons new-board state))))))
*slide-pattern*))
(loop)))))))
最初に関数 make-hash-table でハッシュ表を作成します。キーはベクタなので equal? を指定します。そして、start の盤面をハッシュ表に登録し、start の局面をキューに追加します。局面は盤面と 1 手前の局面を格納したコンスセルで表します。
あとはキューからデータを取り出し、for-each で盤面を 8 方向にスライドして新しい局面 new-board を生成します。goal に到達したら print-answer で手順を表示して探索を終了します。new-board がハッシュ表に登録されていなければ、それをハッシュ表に登録し、局面をキューに追加して探索を続行します。
あとのプログラムは簡単なので説明は割愛いたします。詳細は プログラムリスト５ をお読みください。
実行結果は次のようになりました。
#(9 8 7 6 5 4 3 2 1) #(1 8 7 6 9 4 3 2 5) #(1 8 3 6 7 4 9 2 5) #(1 2 3 6 8 4 9 7 5) #(1 2 3 4 6 8 9 7 5) #(6 2 3 4 5 8 9 7 1) #(6 2 5 4 9 8 3 7 1) #(1 2 5 4 6 8 3 7 9) #(1 6 5 4 7 8 3 2 9) #(1 6 3 4 5 8 7 2 9) #(1 6 3 5 8 4 7 2 9) #(1 2 3 5 6 4 7 8 9) #(1 2 3 4 5 6 7 8 9)
これを図に示すと次のようになります。
9 8 7 6 5 4 3 2 1 [START] 1 8 7 1 8 3 1 2 3 1 2 3 6 2 3 6 2 5 6 9 4 6 7 4 6 8 4 4 6 8 4 5 8 4 9 8 3 2 5 9 2 5 9 7 5 9 7 5 9 7 1 3 7 1 [1] [2] [3] [4] [5] [6] 1 2 5 1 6 5 1 6 3 1 6 3 1 2 3 1 2 3 4 6 8 4 7 8 4 5 8 5 8 4 5 6 4 4 5 6 3 7 9 3 2 9 7 2 9 7 2 9 7 8 9 7 8 9 [7] [8] [9] [10] [11] [GOAL:12]
ちなみに、最長手数は 12 手で 13 通りの局面が見つかりました。START の局面はその中のひとつです。このとき生成された局面数は 181440 通りなので、８パズルと同様に駒をランダムに配置すると解けない場合があります。
;
; slide.scm : スライドパズル
;
; Copyright (C) 2010 Makoto Hiroi
;
; スライドパターン
(define *slide-pattern*
'((8 4 0) (6 4 2) (7 4 1) (5 4 3)
(0 4 8) (2 4 6) (1 4 7) (3 4 5)))
; キューの定義
(define buff (make-vector 362880))
(define wp 0)
(define rp 0)
(define (clear!)
(set! wp 0)
(set! rp 0))
(define (enqueue! x)
(vector-set! buff wp x)
(inc! wp))
(define (dequeue!)
(begin0 (vector-ref buff rp)
(inc! rp)))
(define (print-answer state)
(if (pair? (cdr state))
(print-answer (cdr state)))
(print (car state)))
(define (print-max-state)
(print rp)
(let ((m (cdr (vector-ref buff (- rp 1)))))
(let loop ((i (- rp 1)))
(cond ((= (cdr (vector-ref buff i)) m)
(print (vector-ref buff i))
(loop (- i 1)))))))
; 盤面の生成
(define (make-new-board board ls)
(let ((new-board (vector-copy board)))
(vector-set! new-board (car ls) (vector-ref board (cadr ls)))
(vector-set! new-board (cadr ls) (vector-ref board (caddr ls)))
(vector-set! new-board (caddr ls) (vector-ref board (car ls)))
new-board))
; 幅優先探索
(define (solve start goal)
(define ht (make-hash-table 'equal?))
;
(hash-table-put! ht start #t)
(enqueue! (cons start '()))
(call/cc
(lambda (break)
(let loop ()
(cond ((< rp wp)
(let ((state (dequeue!)))
(for-each
(lambda (pat)
(let ((new-board (make-new-board (car state) pat)))
(cond ((equal? new-board goal)
(print-answer (cons new-board state))
(break #t))
((not (hash-table-get ht new-board #f))
(hash-table-put! ht new-board #t)
(enqueue! (cons new-board state))))))
*slide-pattern*))
(loop)))))))
;;;
;;; 最長手数の探索
;;;
(define (solve-max)
(define ht (make-hash-table 'equal?))
;
(hash-table-put! ht #(1 2 3 4 5 6 7 8 9) #t)
(clear!)
(enqueue! (cons #(1 2 3 4 5 6 7 8 9) 0))
(let loop ()
(cond ((< rp wp)
(let ((state (dequeue!)))
(for-each
(lambda (pat)
(let ((new-board (make-new-board (car state) pat)))
(cond ((not (hash-table-get ht new-board #f))
(hash-table-put! ht new-board #t)
(enqueue! (cons new-board (+ (cdr state) 1)))))))
*slide-pattern*))
(loop))))
;
(print-max-state))
(solve #(9 8 7 6 5 4 3 2 1) #(1 2 3 4 5 6 7 8 9))
(solve-max)