パズルに挑戦 (3)
●問題３「ペグ・ソリティア」の解答
それでは、プログラムを作りましょう。最小手数を求めるアルゴリズムといえば「幅優先探索」ですが、チャイニーズ・チェッカーは単純な「反復深化」でも解くことができます。
プログラムのポイントは、ペグを跳び越すときに手数も同時に数えていくことです。直前に動かしたペグと違うペグを動かすときは手数をカウントし、同じペグを動かすときは手数をカウントしません。これで連続跳び越しを 1 手と数えることができます。そして、この手数を使って反復深化を実行するわけです。
今回は盤面をベクタで、ペグの有無を真偽値 (#t, #f) で表します。ベクタの添字と盤面の対応は下図を参照してください。
ペグの移動は跳び先表を用意すると簡単です。次のリストを見てください。
リスト : 跳び先表
;;; 跳び先表
(define *jump-table*
#(((1 3) (2 5)) ; 0
((3 6) (4 8)) ; 1
((4 7) (5 9)) ; 2
((1 0) (4 5) (6 10) (7 12)) ; 3
((7 11) (8 13)) ; 4
((2 0) (4 3) (8 12) (9 14)) ; 5
((3 1) (7 8)) ; 6
((4 2) (8 9)) ; 7
((4 1) (7 6)) ; 8
((5 2) (8 7)) ; 9
((6 3) (11 12)) ; 10
((7 4) (12 13)) ; 11
((7 3) (8 5) (11 10) (13 14)) ; 12
((8 4) (12 11)) ; 13
((9 5) (13 12)))) ; 14
ペグの跳び先表はベクタ *jump-table* で定義します。ベクタの要素はリストであることに注意してください。リストの要素は、跳び越されるペグの位置と跳び先の位置を格納したリストです。たとえば、0 番の位置にあるペグは、1 番を跳び越して 3 番へ移動する場合と、2 番を跳び越して 5 番へ移動する場合の 2 通りがあります。これをリスト (1 3) と (2 5) で表しています。
次はペグを操作する関数を作ります。
リスト : ペグの操作関数
;;; 定数
(define HOLE 12)
(define MAX-JUMP 13)
(define SIZE 15)
;;; 大域変数
(define board (make-vector SIZE #t)) ; 盤面
;;; ペグの移動
(define (move-peg from del to)
(vector-set! board from #f)
(vector-set! board del #f)
(vector-set! board to #t))
;;; ペグを元に戻す
(define (restore-peg from del to)
(vector-set! board from #t)
(vector-set! board del #t)
(vector-set! board to #f))
盤面は大域変数 board に格納します。駒の移動は board を書き換えて、バックトラックする時は元に戻すことにします。関数 move-peg はペグを from から del を跳び越して to へ移動します。restore-peg は移動したペグを元に戻す関数です。
次は反復深化で解を探す関数 solver を作ります。
リスト : 反復深化
(define (solver ret)
;; 深さ優先探索
(define (dfs n jc limit move)
(when
(<= jc limit)
(cond
((= n MAX-JUMP)
(when
(vector-ref board HOLE)
(print-answer (cdr (reverse move)))
(ret #t)))
(else
(do ((from 0 (+ from 1)))
((>= from SIZE))
(when
(vector-ref board from)
(for-each
(lambda (pos)
(let ((del (car pos)) (to (cadr pos)))
(when
(and (vector-ref board del)
(not (vector-ref board to)))
(move-peg from del to)
(dfs (+ n 1)
(if (= from (cdar move)) jc (+ jc 1))
limit
(cons (cons from (cadr pos)) move))
(restore-peg from del to))))
(vector-ref *jump-table* from))))))))
;;
(vector-set! board HOLE #f)
(let loop ((i 1))
(cond
((<= i MAX-JUMP)
(display "----- ") (display i) (display " -----\n")
(dfs 0 0 i '((-1 . -1)))
(loop (+ i 1))))))
solver の引数 ret は脱出用の継続です。実際の処理は局所関数 dfs で行います。引数 n がペグを動かした回数、jc が手数 (跳んだ回数)、limit が反復深化の上限値、move がペグの移動手順を表します。移動手順は (跳ぶペグの位置 跳び先の位置) をリストに格納して表します。
チャイニーズ・チェッカーの場合、ペグの総数は 14 個なので、13 回 (MAX-JUMP) ペグを移動するとペグの個数は 1 つになります。そして、そのペグが 12 番目 (HOLE) にあるならば、解を見つけることができました。関数 print-answer で手順を表示し、継続 ret を評価して処理を終了します。
そうでなければペグを移動します。do ループの変数 from が移動するペグを表します。from にペグがある場合、*jump-table* から跳び越すペグの位置と跳び先の位置を求め、変数 del と to にセットします。del の位置にペグがあり to の位置が空であればペグを移動することができます。関数 move-peg でペグを移動して dfs を再帰呼び出しします。
このとき、move の先頭要素 (prev-from prev-to) の prev-to と from を比較して、等しい場合は連続跳び越しと判断することができます。この場合は jc の値を増やしません。そうでなければ jc の値を +1 します。再帰呼び出しから戻ってきたら restore-peg でペグを元に戻します。
あとは特に難しいところはないと思います。詳細は プログラムリスト をお読みくださいませ。
●実行結果
これでプログラムは完成です。実行結果は次のようになりました。
----- 1 -----
----- 2 -----
----- 3 -----
----- 4 -----
----- 5 -----
----- 6 -----
----- 7 -----
----- 8 -----
----- 9 -----
[10,12][13,11][3,10,12,3][1,6][5,3][6,1][14,5][2,9,7][0,3,12]
最短手数は 9 手になりました。実行時間は 5.3 秒 (Gauche 0.9.9, Ubunts 18.04 (Windows Subsystem for Linux), Intel Core i5-6200U 2.30GHz) でした。初手を 3 -> 12 と 10 -> 12 に限定すると、実行時間はもう少し速くなります。もっと速くしたい場合は「下限値枝刈り法」を使ってみるといいでしょう。興味のある方は挑戦してみてください。
●プログラムリスト３
;;;
;;; peg15.scm : チャイニーズ・チェッカー
;;;
;;; Copyright (C) 2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write))
;;; 跳び先表
(define *jump-table*
#(((1 3) (2 5)) ; 0
((3 6) (4 8)) ; 1
((4 7) (5 9)) ; 2
((1 0) (4 5) (6 10) (7 12)) ; 3
((7 11) (8 13)) ; 4
((2 0) (4 3) (8 12) (9 14)) ; 5
((3 1) (7 8)) ; 6
((4 2) (8 9)) ; 7
((4 1) (7 6)) ; 8
((5 2) (8 7)) ; 9
((6 3) (11 12)) ; 10
((7 4) (12 13)) ; 11
((7 3) (8 5) (11 10) (13 14)) ; 12
((8 4) (12 11)) ; 13
((9 5) (13 12)))) ; 14
;;; 定数
(define HOLE 12)
(define MAX-JUMP 13)
(define SIZE 15)
;;; 大域変数
(define board (make-vector SIZE #t)) ; 盤面
;;; ペグの移動
(define (move-peg from del to)
(vector-set! board from #f)
(vector-set! board del #f)
(vector-set! board to #t))
(define (restore-peg from del to)
(vector-set! board from #t)
(vector-set! board del #t)
(vector-set! board to #f))
;;; 手順の表示
(define (print-answer move)
(let ((prev (cdar move)))
;; 初手を表示
(display "[") (display (caar move)) (display ",") (display prev)
;; 2 手目以降を表示する
(for-each
(lambda (x)
(cond
((= prev (car x))
(set! prev (cdr x))
;; 同じ駒が続けて跳ぶ
(display ",") (display prev))
(else
(set! prev (cdr x))
(display "][") (display (car x))
(display ",") (display prev))))
(cdr move))
(display "]\n")))
;;; 反復深化による解法
(define (solver ret)
;; 深さ優先探索
(define (dfs n jc limit move)
(when
(<= jc limit)
(cond
((= n MAX-JUMP)
(when
(vector-ref board HOLE)
(print-answer (cdr (reverse move)))
(ret #t)))
(else
(do ((from 0 (+ from 1)))
((>= from SIZE))
(when
(vector-ref board from)
(for-each
(lambda (pos)
(let ((del (car pos)) (to (cadr pos)))
(when
(and (vector-ref board del)
(not (vector-ref board to)))
(move-peg from del to)
(dfs (+ n 1)
(if (= from (cdar move)) jc (+ jc 1))
limit
(cons (cons from (cadr pos)) move))
(restore-peg from del to))))
(vector-ref *jump-table* from))))))))
;;
(vector-set! board HOLE #f)
(let loop ((i 1))
(cond
((<= i MAX-JUMP)
(display "----- ") (display i) (display " -----\n")
(dfs 0 0 i '((-1 . -1)))
(loop (+ i 1))))))
;;; 実行
(call/cc
(lambda (cont) (solver cont)))
●問題４「８めくり」の解答
それではプログラムを作りましょう。盤面はベクタで表します。オン・オフの状態を #t と #f で表し、ベクタの添字とボタンの番号を下図のように対応させます。
ボタンを押してライトの状態を反転する処理も簡単です。たとえば、ボタン 5 を押した場合、0, 1, 2, 4, 6, 8, 9, 10 のライトを反転させます。ベクタの要素は真偽値なので、not を適用すれば #t を #f に、#f を #t に変換することができます。
８めくりは同じボタンを二度押すと元の状態に戻ります。したがって、同じボタンは二度押さなくてよいことがわかります。また、実際にボタンを押してみるとわかりますが、ボタンを押す順番は関係がないことがわかります。たとえば、ボタン 0 と 1 を押す場合、0 -> 1 と押すのも 1 -> 0 と押すのも同じ結果になります。これはライツアウトとまったく同じです。
この 2 つの法則から、ボタンを押す組み合わせは全部で 2 ^ 16 通りになります。８めくりを解くいちばん単純な方法は、ボタンを押す組み合わせを生成して、実際にライトが全部消えるかチェックすることです。今回は小さい盤なので、単純な方法で解いてみましょう。ただし、この方法は盤面が大きくなると時間がかかります。ご注意ください。
プログラムは次のようになります。
リスト : ８めくりの解法
(define (solver n m)
(define size (* n m))
(define found 0)
(define pattern (make-pattern n m))
;;
(define (check push-list)
(let ((board (make-vector size #t)))
(for-each
(lambda (x)
(for-each
(lambda (y)
(vector-set! board y (not (vector-ref board y))))
(vector-ref pattern x)))
push-list)
(when
(vector-every (lambda (x) (not x)) board)
(set! found (+ found 1))
(display push-list)
(newline))))
;;
(let loop ((i 1))
(when
(<= i size)
(display "----- ") (display i) (display " -----\n")
(combinations check i (iota size 0))
(when
(zero? found)
(loop (+ i 1))))))
関数 solver は n 行 m 列盤の「８めくり」の最短手数を求めます。ボタンを押したときの反転パターンは関数 make-pattern で作成します。返り値はベクタで、変数 pattern にセットします。関数 check は引数 push-list に格納された複数のボタンを押して新しい盤面を生成します。新しい盤面は for-each を使うと簡単に求めることができます。
最初の for-each で押すボタンをラムダ式の引数 x にセットし、次の for-each で反転するボタンの位置をラムダ式の引数 y にセットします。あとは y 番目の要素に not を適用して、値を書き換えるだけです。そして、vector-every ですべてのボタンが消灯していることを確認します。そうであれば、変数 found の値を +1 して、display で押したボタン push-list を表示します。
あとは、押すボタンの個数を一つずつ増やしていき、全てのボタンが消灯するかチェックするだけです。押すボタンは関数 combinations で求めます。これは拙作のページ 順列と組み合わせ で作成したものです。iota は数列を生成する関数です。これは拙作のページ 便利なリスト操作関数 で作成したものです。
あとはとくに難しいところはないと思います。説明は割愛するので、詳細は プログラムリスト４ をお読みください。
実行結果は次のようになりました。
$ gosh -A . turn8.scm
----- 1 -----
----- 2 -----
----- 3 -----
----- 4 -----
----- 5 -----
----- 6 -----
(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 通りの手順が出力されました。これを図に示すと次のようになります。
ところで、最長手数を幅優先探索 (関数 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 通り) になります。
なお、８めくりはライツアウトと同様に連立方程式を使うと大きな盤面でも高速に解くことができます。興味のある方は以下のページをお読みくださいませ。
●プログラムリスト４
;;;
;;; turn8.scm : 8 めくり
;;;
;;; Copyright (C) 2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write)
(mylib list) ; プログラムリスト を参照
(mylib vector))
;;; n 行 m 列のパターンを作成
(define (make-pattern n m)
;; 隣の位置を求める
(define (neighbors x y)
(map (lambda (z) (+ (* (cdr z) m) (car z)))
(filter
(lambda (z) (and (< -1 (car z) m) (< -1 (cdr z) n)))
(map (lambda (z) (cons (+ x (car z)) (+ y (cdr z))))
'((-1 . -1) (0 . -1) (1 . -1) (-1 . 0) (1 . 0) (-1 . 1) (0 . 1) (1 . 1))))))
;;
(let* ((size (* n m))
(pattern (make-vector size)))
(do ((i 0 (+ i 1)))
((>= i size) pattern)
(let ((x (modulo i m)) (y (quotient i m)))
(vector-set! pattern i (neighbors x y))))))
;;; 組み合わせの生成
(define (combinations func n ls)
(define (comb n ls a)
(cond
((zero? n)
(func (reverse a)))
((pair? ls)
(comb (- n 1) (cdr ls) (cons (car ls) a))
(comb n (cdr ls) a))))
(comb n ls '()))
;;; 解法
(define (solver n m)
(define size (* n m))
(define found 0)
(define pattern (make-pattern n m))
;;
(define (check push-list)
(let ((board (make-vector size #t)))
(for-each
(lambda (x)
(for-each
(lambda (y)
(vector-set! board y (not (vector-ref board y))))
(vector-ref pattern x)))
push-list)
(when
(vector-every (lambda (x) (not x)) board)
(set! found (+ found 1))
(display push-list)
(newline))))
;;
(let loop ((i 1))
(when
(<= i size)
(display "----- ") (display i) (display " -----\n")
(combinations check i (iota size 0))
(when
(zero? found)
(loop (+ i 1))))))
;;; 最長手数の探索
(define (solver-max n m)
(define size (* n m))
(define found 0)
(define pattern (make-pattern n m))
(define hash-table (make-vector (expt 2 size) #f))
(define (hash-func board)
(vector-foldl (lambda (a x) (if x (+ (* 2 a) 1) (* 2 a))) 0 board))
;;
(define (check push-list)
(let ((board (make-vector size #f)))
(for-each
(lambda (x)
(for-each
(lambda (y)
(vector-set! board y (not (vector-ref board y))))
(vector-ref pattern x)))
push-list)
(let ((hash-value (hash-func board)))
(unless
(vector-ref hash-table hash-value)
(vector-set! hash-table hash-value #t)
(set! found (+ found 1))))))
;;
(vector-set! hash-table 0 #t)
(let loop ((i 1))
(when
(<= i size)
(set! found 0)
(display i) (display " moves: ")
(combinations check i (iota size 0))
(display found)
(newline)
(loop (+ i 1)))))
;;; 実行
;;;(solver-max 4 4)
(solver 4 4)
●問題５「スライドパズル」の解答
今回は「幅優先探索」でプログラムを作りましょう。9 種類の駒があるので、局面の総数は 9! = 362880 通りあります。同一局面のチェックに線形探索を使うと時間がかかるのでハッシュ表を使うことにします。
盤面はベクタで表します。盤面の位置を下図のように表すと、駒をスライドして新しい盤面を生成するプログラムは次のようになります。
リスト : 新しい盤面を生成する
;;; スライドパターン
(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 ((newbd (vector-copy board)))
(vector-set! newbd (car ls) (vector-ref board (cadr ls)))
(vector-set! newbd (cadr ls) (vector-ref board (caddr ls)))
(vector-set! newbd (caddr ls) (vector-ref board (car ls)))
newbd))
スライドする 8 方向をリストで定義します。リストが (x y z) とすると、x 番目の駒を z 番目に、y 番目の駒を x 番目に、z 番目の駒を y 番目に移動します。この処理を関数 make-new-board で行います。あとは単純な幅優先探索です。プログラムは次のようになります。
リスト : 幅優先探索
(define (solver start goal ret)
;; キューとハッシュ表
(define q (make-queue))
(define ht (make-hash-table 181499 hash-func equal?))
;; 初期化
(hash-set! ht start #t)
(enqueue! q (make-state start '()))
(do ()
((queue-empty? q) #f)
(let ((st (dequeue! q)))
(for-each
(lambda (pat)
(let* ((newbd (make-new-board (get-board st) pat))
(newst (make-state newbd st)))
(cond
((equal? newbd goal)
(print-answer newst)
(ret #t))
((not (hash-find ht newbd))
(hash-set! ht newbd #t)
(enqueue! q newst)))))
*slide-pattern*))))
最初に関数 make-queue でキューを、関数 make-hash-table でハッシュ表を作成します。キーはベクタなので等値の判定には equal? を指定します。そして、start の盤面をハッシュ表に登録し、start の局面をキューに追加します。局面は盤面と 1 手前の局面を格納したレコード型 State で表します。
あとはキューからデータを取り出し、for-each で盤面を 8 方向にスライドして新しい局面 newbd を生成します。goal に到達したら関数 print-answer で手順を表示し、継続 ret を評価して探索を終了します。newbd がハッシュ表に登録されていなければ、それをハッシュ表に登録し、局面をキューに追加して探索を続行します。
あとのプログラムは簡単なので説明は割愛いたします。詳細は プログラムリスト５ をお読みください。
実行結果は次のようになりました。
#(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-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write) (scheme cxr)
(mylib queue) ; プログラムリスト を参照
(mylib hash)
(mylib vector))
;;; サイズ
(define *size* 9)
;;; スライドパターン
(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-record-type State
(make-state board prev)
state?
(board get-board)
(prev get-prev))
;;; 手順の表示
(define (print-answer st)
(when
(state? st)
(print-answer (get-prev st))
(display (get-board st))
(newline)))
;;; 盤面の生成
(define (make-new-board board ls)
(let ((newbd (vector-copy board)))
(vector-set! newbd (car ls) (vector-ref board (cadr ls)))
(vector-set! newbd (cadr ls) (vector-ref board (caddr ls)))
(vector-set! newbd (caddr ls) (vector-ref board (car ls)))
newbd))
;;; ハッシュ関数
(define (hash-func board)
(vector-foldl (lambda (a x) (+ (* a *size*) x)) 0 board))
;;; 幅優先探索
(define (solver start goal ret)
;; キューとハッシュ表
(define q (make-queue))
(define ht (make-hash-table 181499 hash-func equal?))
;; 初期化
(hash-set! ht start #t)
(enqueue! q (make-state start '()))
(do ()
((queue-empty? q) #f)
(let ((st (dequeue! q)))
(for-each
(lambda (pat)
(let* ((newbd (make-new-board (get-board st) pat))
(newst (make-state newbd st)))
(cond
((equal? newbd goal)
(print-answer newst)
(ret #t))
((not (hash-find ht newbd))
(hash-set! ht newbd #t)
(enqueue! q newst)))))
*slide-pattern*))))
;;;
;;; 最長手数の探索
;;;
(define (solver-max)
(define start #(1 2 3 4 5 6 7 8 9))
(define ht (make-hash-table 181499 hash-func equal?))
;;
(hash-set! ht start #t)
(let loop ((olds (list start)) (i 0))
(let ((news '()))
(for-each
(lambda (bd)
(for-each
(lambda (pat)
(let ((newbd (make-new-board bd pat)))
(unless
(hash-find ht newbd)
(hash-set! ht newbd #t)
(set! news (cons newbd news)))))
*slide-pattern*))
olds)
;;
(cond
((null? news)
(for-each (lambda (bd) (display bd) (newline)) olds)
(display i)
(newline))
(else
(loop news (+ i 1)))))))
;;; 実行
(call/cc
(lambda (cont)
(solver #(9 8 7 6 5 4 3 2 1) #(1 2 3 4 5 6 7 8 9) cont)))
;;;(solver-max)
初版 2010 年 5 月 15 日
改訂 2020 年 9 月 30 日
