パズルの解法 [2]
今回は幅優先探索の例題として 15 パズルで有名なスライドパズルを解いてみましょう。
●８パズルの説明
参考文献 1 によると、15 パズルはアメリカのサム・ロイドが 1870 年代に考案したパズルで、彼はパズルの神様と呼ばれるほど有名なパズル作家だそうです。
図 : 15 パズル
15 パズルは上図に示すように、1 から 15 までの駒を並べるパズルです。駒の動かし方は、1 回に 1 個の駒を空いている隣の場所に滑らせる、というものです。駒を跳び越したり持ち上げたりすることはできません。
15 パズルの場合、駒の配置は空き場所がどこでもいいことにすると、16! (約 2e13) 通りもあります。実際には、15 パズルの性質からその半分になるのですが、それでもパソコンで扱うにはあまりにも大きすぎる数です。そこで、盤面を一回り小さくした、1 から 8 までの数字を並べる「8 パズル」を考えることにします。
図 : 8 パズル
15 パズルは 4 行 4 列の盤ですが、8 パズルは 3 行 3 列の盤になります。8 パズルの場合、駒の配置は空き場所がどこでもいいことにすると、9! = 362880 通りあります。15 パズルや 8 パズルの場合、参考文献 2 によると 『適当な 2 つの駒をつまみ上げて交換する動作を偶数回行った局面にしか移行できない』 とのことです。
上図 (2) は 7 と 8 を入れ替えただけの配置です。この場合、交換の回数が奇数回のため完成形に到達することができない、つまり解くことができないのです。このような性質を「偶奇性 (パリティ)」といいます。詳しい説明は拙作のページ Puzzle DE Programming 偶奇性 (パリティ) をお読みください。8 パズルの場合、完成形に到達する局面の総数は 9! / 2 = 181440 個となります。
●幅優先探索による解法
それでは、プログラムを作りましょう。下図に示すスタートから完成形 (ゴール) に到達するまでの最短手数を幅優先探索で求めます。
図 : 8 パズル
8 パズルの盤面はベクタを使って表します。盤面の位置とベクタの添字の対応は下図を見てください。
図 : 8 パズルの盤面
隣接リストの定義は次のようになります。
リスト : 隣接リスト
(define *adjacent*
#((1 3) ; 0
(0 2 4) ; 1
(1 5) ; 2
(0 4 6) ; 3
(1 3 5 7) ; 4
(2 4 8) ; 5
(3 7) ; 6
(4 6 8) ; 7
(5 7))) ; 8
次は局面を表すレコード型を定義します。
リスト : 局面の定義 (define-record-type State (make-state board space prev) state? (board get-board) (space get-space) (prev get-prev))
レコード名は State としました。フィールド board は盤面を表すベクタ、space は空き場所の位置、prev は 1 手前の局面 (State) を格納します。ゴールに到達したら、prev をたどって手順を表示します。そして、各々の要素に対応するアクセス関数を用意します。
それでは幅優先探索のプログラムを作りましょう。次のリストを見てください。
リスト : 幅優先探索
(define (solver start goal ret)
;; キューとハッシュ表
(define q (make-queue))
(define ht (make-hash-table 181499 hash-func equal?))
;; 新しい State を生成してキューとハッシュ表に登録する
(define (make-new-state bd sp p)
(let ((st (make-state bd sp p)))
(enqueue! q st)
(hash-set! ht bd st)))
;; 初期化
(make-new-state start (vector-position zero? start) '())
;; 探索
(do ()
((queue-empty? q) #f)
(let* ((st (dequeue! q))
(sp (get-space st))
(bd (get-board st)))
(for-each
(lambda (x)
(let ((newbd (move-piece bd sp x)))
(cond
((equal? newbd goal)
(print-answer (make-state newbd x st))
;; 継続で脱出する
(ret #t))
((not (hash-find ht newbd))
(make-new-state newbd x st)))))
(vector-ref *adjacent* sp)))))
プログラムの骨格は 経路の探索 で説明した幅優先探索と同じです。関数 solver の引数 start がスタートの盤面、goal がゴールの盤面、ret が脱出先の継続です。まず最初に、キューとハッシュ表を生成します。幅優先探索はキューを使うと簡単にプログラムできます。
今回は Scheme プログラミング中級編 [4] で作成した Queue と、ヒープとハッシュ法 で作成した Hash を使うことにします。詳細は拙作のライブラリ (mylib queue), (mylib hash) をお読みください。hash-func は盤面を整数値に変換するハッシュ関数で、ハッシュ表の大きさは 181499 (素数) としました。盤面はベクタで表しているので、等値関係の述語には equal? を指定します。
それから、関数 make-new-state で start の局面を生成してキューとハッシュ表に登録します。関数 vector-position は拙作のページ Scheme プログラミング中級編 [3] で作成したもので、ベクタから条件を満たす要素を探してその位置を返します。
幅優先探索の場合、手数 を 1 つずつ増やしながら探索を行います。このため、n 手目の移動で作られた局面が n 手以前の局面で出現している場合、n 手より短い手数で到達する移動手順が必ず存在します。最短手順を求めるのであれば、この n 手の手順を探索する必要はありません。ハッシュ表 ht をチェックして新しい局面だけキューに登録します。
次の do ループで、goal に到達するまで探索を繰り返します。キューが空になり do ループが終了する場合、start は goal に到達できない、つまり解くことができなかったことになります。キューから局面を取り出して変数 st にセットします。そして、盤面を変数 bd に、空き場所を変数 sp にセットします。
次の for-each で、隣接リストから空き場所 sp の隣の位置を求めます。ラムダ式の引数 x が動かす駒の位置になります。関数 move-piece で駒を動かして盤面を生成して変数 newbd にセットします。そして、cond の最初の節で bd が goal と等しいか equal? でチェックします。そうであれば、解を見つけたので関数 print-answer で手順を表示し、継続 ret を評価して探索を終了します。
ゴールに到達していない場合、関数 hash-find で同一局面をチェックします。同一局面がない場合は、make-new-state で新しい局面を生成してキューとハッシュ表に追加します。このとき、空き場所の位置は x で、1 手前の局面は st になります。
あとのプログラムは簡単なので、説明は省略いたします。詳細は プログラムリスト１ をお読みください。
●実行結果
これでプログラムは完成です。それでは実行してみましょう。
$ gosh -A . eight.scm 8 6 7 2 5 4 3 0 1 8 6 7 2 0 4 3 5 1 省略 1 2 3 4 5 6 7 0 8 1 2 3 4 5 6 7 8 0 2.1559726
31 手で解くことができました。生成した局面は全部で 181440 通りで、実行時間は 2.2 秒 (Gauche version 0.9.9, Ubunts 18.04, Windows Subsystem for Linux, Intel Core i5-6200U 2.30GHz) かかりました。8 パズルの場合、最長手数は 31 手で、下図に示す 2 通りの局面があります。スタートの局面はその一つです。
図 : 31 手で解ける局面
最長手数の局面は、幅優先探索を使って求めることができます。これはあとで試してみましょう。
●プログラムリスト１
;;;
;;; eight.scm : 8 Puzzle の解法
;;;
;;; Copyright (C) 2008-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write) (scheme time)
(mylib queue)
(mylib hash))
;;; 盤面の大きさ
(define *size* 9)
;;; 隣接リスト
(define *adjacent*
#((1 3) ; 0
(0 2 4) ; 1
(1 5) ; 2
(0 4 6) ; 3
(1 3 5 7) ; 4
(2 4 8) ; 5
(3 7) ; 6
(4 6 8) ; 7
(5 7))) ; 8
;;; 局面の定義
(define-record-type State
(make-state board space prev)
state?
(board get-board)
(space get-space)
(prev get-prev))
;;; 盤面の表示
(define (print-board board)
(let loop ((i 0))
(when
(< i *size*)
(display (vector-ref board i))
(display " ")
(if (or (= i 2) (= i 5) (= i 8)) (newline))
(loop (+ i 1))))
(newline))
;;; 解の表示
(define (print-answer state)
(when
(state? state)
(print-answer (get-prev state))
(print-board (get-board state))))
;;; 駒の移動
(define (move-piece board space pos)
(let ((new-board (vector-copy board)))
(vector-set! new-board space (vector-ref new-board pos))
(vector-set! new-board pos 0)
new-board))
;;; 見つけたデータの位置を返す
(define (vector-position p vs)
(do ((k (vector-length vs))
(i 0 (+ i 1)))
((or (>= i k)
(p (vector-ref vs i)))
(if (< i k) i #f))))
;;; ベクタの畳み込み
(define (vector-foldl fn a vec)
(vector-for-each (lambda (x) (set! a (fn a x))) vec)
a)
;;; ハッシュ関数
(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?))
;; 新しい State を生成してキューとハッシュ表に登録する
(define (make-new-state bd sp p)
(let ((st (make-state bd sp p)))
(enqueue! q st)
(hash-set! ht bd st)))
;; 初期化
(make-new-state start (vector-position zero? start) '())
;; 探索
(do ()
((queue-empty? q) #f)
(let* ((st (dequeue! q))
(sp (get-space st))
(bd (get-board st)))
(for-each
(lambda (x)
(let ((newbd (move-piece bd sp x)))
(cond
((equal? newbd goal)
(print-answer (make-state newbd x st))
(ret #t)) ; 継続で脱出する
((not (hash-find ht newbd))
(make-new-state newbd x st)))))
(vector-ref *adjacent* sp)))))
;;; 実行
(let ((s (current-jiffy)))
(call/cc
(lambda (cont)
(solver #(8 6 7 2 5 4 3 0 1) #(1 2 3 4 5 6 7 8 0) cont)))
(display (inexact (/ (- (current-jiffy) s) (jiffies-per-second))))
(newline))
●双方向探索
ところで、今回の 8 パズルのようにゴールの状態が明確な場合、スタートから探索するだけではなくゴールからも探索を行うことで、幅優先探索を高速化することができます。これを「双方向探索 (bi-directional search)」といいます。
その理由を説明するために、簡単なシミュレーションをしてみましょう。たとえば、1 手進むたびに 3 つの局面が生成され、5 手で解けると仮定します。すると、n 手目で生成される局面は 3 の n 乗個になるので、初期状態から単純に探索すると、生成される局面の総数は、3 + 9 + 27 + 81 + 243 = 363 個となります。
これに対し、初期状態と終了状態から同時に探索を始めた場合、お互い 3 手まで探索した時点で同じ局面に到達する、つまり、解を見つけることができます。この場合、生成される局面の総数は 3 手目までの局面数を 2 倍した 78 個となります。
生成される局面数はぐっと少なくなりますね。局面数が減少すると同一局面の探索処理に有利なだけではなく、「キューからデータを取り出して新しい局面を作る」という根本的な処理のループ回数を減らすことになるので、処理速度は大幅に向上するのです。
それではプログラムを作りましょう。単純に考えると、2 つの探索処理を交互に行うことになりますが、そうするとプログラムの大幅な修正が必要になります。ここは、探索方向を示すフラグを用意することで、一つのキューだけで処理することにしましょう。局面を表すリストに方向を示す要素を追加します。
リスト : 局面の定義 (双方向からの探索) (define-record-type State (make-state board space prev dir) state? (board get-board) (space get-space) (prev get-prev) (dir get-dir))
スタートからの探索をシンボル F で、ゴールからの探索をシンボル B で表ます。双方向探索のプログラムは次のようになります。
リスト : 双方向探索
(define (solver start goal ret)
;; キューとハッシュ表
;;
;; ・・・ 省略 ・・・
;;
;; 初期化
(make-new-state start (vector-position zero? start) '() 'F)
(make-new-state goal (vector-position zero? goal) '() 'B)
;; 探索
(do ()
((queue-empty? q))
(let* ((st (dequeue! q))
(sp (get-space st))
(bd (get-board st)))
(for-each
(lambda (x)
(let* ((newbd (move-piece bd sp x))
(oldst (hash-find ht newbd)))
(cond
(oldst
(unless
(eq? (get-dir oldst) (get-dir st))
;; 方向が異なる (解を見つけた)
(print-answer oldst st)
;; 継続 ret を評価して脱出する
(ret #t)))
(else
(make-new-state newbd x st (get-dir st))))))
(vector-ref *adjacent* sp)))))
スタートとゴールの局面を生成してキューとハッシュ表に登録します。最初に、スタートの状態から 1 手目の局面が生成され、次にゴールの状態から 1 手目の局面が生成されます。あとは、交互に探索が行われます。それから、同一局面を見つけたとき、その局面の方向 dir を比較する必要があるので、ハッシュ表には局面を表すリストをセットします。
駒の移動と局面の生成処理は幅優先探索と同じです。新しい局面 newbd を生成して、同じ局面がないかハッシュ表を探索して結果を変数 oldst にセットします。同じ局面を見つけたとき、st と oldst の探索方向が異なっていれば、双方向からの探索で同一局面に到達したことがわかります。見つけた最短手順を関数 print-answer で出力します。同じ探索方向であれば、キューへの追加は行いません。
あとのプログラムは簡単なので、説明は省略いたします。詳細は プログラムリスト２ をお読みください。
さっそく実行してみると、生成された局面数は 16088 個で、実行時間は 0.14 秒でした。局面数は約 1 / 11 になり、実行時間も約 16 倍と高速になりました。
●プログラムリスト２
;;;
;;; eight1.scm : 8 Puzzle の解法 (双方向探索)
;;;
;;; Copyright (C) 2008-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write) (scheme time)
(mylib queue)
(mylib hash))
;;; 盤面の大きさ
(define *size* 9)
;;; 隣接リスト
(define *adjacent*
#((1 3) ; 0
(0 2 4) ; 1
(1 5) ; 2
(0 4 6) ; 3
(1 3 5 7) ; 4
(2 4 8) ; 5
(3 7) ; 6
(4 6 8) ; 7
(5 7))) ; 8
;;; 局面の定義
(define-record-type State
(make-state board space prev dir)
state?
(board get-board)
(space get-space)
(prev get-prev)
(dir get-dir))
;;; 盤面の表示
(define (print-board board)
(newline)
(let loop ((i 0))
(when
(< i *size*)
(display (vector-ref board i))
(display " ")
(if (or (= i 2) (= i 5) (= i 8)) (newline))
(loop (+ i 1)))))
;;; 解の表示 (双方向探索用)
(define (print-answer-f state)
(when
(state? state)
(print-answer-f (get-prev state))
(print-board (get-board state))))
(define (print-answer-b state)
(when
(state? state)
(print-board (get-board state))
(print-answer-b (get-prev state))))
(define (print-answer state1 state2)
(cond
((eq? (get-dir state1) 'F)
(print-answer-f state1)
(print-answer-b state2))
(else
(print-answer-f state2)
(print-answer-b state1))))
;;; 駒の移動
(define (move-piece board space pos)
(let ((new-board (vector-copy board)))
(vector-set! new-board space (vector-ref new-board pos))
(vector-set! new-board pos 0)
new-board))
;;; 見つけたデータの位置を返す
(define (vector-position p vs)
(do ((k (vector-length vs))
(i 0 (+ i 1)))
((or (>= i k)
(p (vector-ref vs i)))
(if (< i k) i #f))))
;;; ベクタの畳み込み
(define (vector-foldl fn a vec)
(vector-for-each (lambda (x) (set! a (fn a x))) vec)
a)
;;; ハッシュ関数
(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?))
;; 新しい State を生成してキューとハッシュ表に登録する
(define (make-new-state bd sp p d)
(let ((st (make-state bd sp p d)))
(enqueue! q st)
(hash-set! ht bd st)))
;; 初期化
(make-new-state start (vector-position zero? start) '() 'F)
(make-new-state goal (vector-position zero? goal) '() 'B)
;; 探索
(do ()
((queue-empty? q))
(let* ((st (dequeue! q))
(sp (get-space st))
(bd (get-board st)))
(for-each
(lambda (x)
(let* ((newbd (move-piece bd sp x))
(oldst (hash-find ht newbd)))
(cond
(oldst
(unless
(eq? (get-dir oldst) (get-dir st))
;; 方向が異なる (解を見つけた)
(print-answer oldst st)
;; 継続 ret を評価して脱出する
(ret #t)))
(else
(make-new-state newbd x st (get-dir st))))))
(vector-ref *adjacent* sp)))))
;;; 実行
(let ((s (current-jiffy)))
(call/cc
(lambda (cont)
(solver #(8 6 7 2 5 4 3 0 1) #(1 2 3 4 5 6 7 8 0) cont)))
(display (inexact (/ (- (current-jiffy) s) (jiffies-per-second))))
(newline))
●最長手数の求め方
今度は最長手数の局面を求めてみましょう。最長手数の求め方ですが、181440 通りの配置の最短手数がすべてわかれば、最長の手数となる配置を求めることができます。しかし、この方法では時間がとてもかかりそうです。そこで、完成形から始めていちばん長い手数の局面を生成することにします。
まず、完成形から駒を動かして 1 手で到達する局面をすべて作ります。次に、これらの局面から駒を動かして新しい局面を作れば、完成形から 2 手で到達する局面となります。このように、手数を 1 手ずつ伸ばしていき、新しい局面が生成できなくなった時点での手数が求める最長手数となります。この処理は幅優先探索を使えばぴったりです。
このプログラムの目的は、いちばん長い手数となる配置を求めることなので、その手順を表示することは行いません。このため、1 手前の局面を格納する第 3 要素 prev は不要になります。そのかわり、その局面までの手数を表す move を用意します。1 手前の局面の手数を move から求め、それに 1 を足せば現在の局面の手数となります。
●プログラムの作成
それではプログラムを作ります。次のリストを見てください。
リスト : 8 パズルの最長手数を求める
(define (solver)
;; ハッシュ表
(define ht (make-hash-table 181499 hash-func equal?))
;; 幅優先探索
(define (bfs xs)
(let ((ys (foldl
(lambda (a st)
(let ((sp (get-space st))
(bd (get-board st)))
(foldl
(lambda (b x)
(let ((newbd (move-piece bd sp x)))
(cond
((hash-find ht newbd) b)
(else
(hash-set! ht newbd #t)
(cons (make-state newbd x (+ (get-move st) 1)) b)))))
a
(vector-ref *adjacent* sp))))
'()
xs)))
(if (pair? ys)
(bfs ys)
(for-each print-answer xs))))
;;
(let* ((start #(1 2 3 4 5 6 7 8 0))
(init-state (make-state start 8 0)))
(hash-set! ht start #t)
(bfs (list init-state))))
実際の処理は局所関数 bfs で行います。bfs は n 手の局面を格納したリストを引数 xs に受け取ります。そして、そこから n + 1 手の局面を生成してリストに格納し、変数 ys にセットします。もしも、ys が空リストであれば、xs の局面が最長手数の局面となります。そうでなければ、探索処理を続行します。この処理を再帰呼び出しで実現しています。
新しい局面の生成は畳み込みを行う関数 foldl を使うと簡単です。ここで foldl を二重で使っていることに注意してください。最初の foldl で xs から局面を一つずつ取り出します。ラムダ式の第 1 引数 a が新しい局面を格納する累積変数 (リスト) で、第 2 引数が局面 st です。
次の foldl で盤面の駒を動かして新しい局面を生成します。ラムダ式の第 1 引数 b が新しい局面を格納する累積変数 (リスト) で、第 2 引数 x が移動する駒の位置です。b の初期値は最初の foldl の累積変数が渡されるので、新しい局面をここに蓄積して返すことができます。あとは、新しい盤面を生成してハッシュ表 ht をチェックし、同一の盤面がなければ新しい局面を b に追加して返します。そうでなければ b をそのまま返します。
あとのプログラムは簡単なので、説明は省略いたします。詳細は プログラムリスト３ をお読みください。
●実行結果
これでプログラムは完成です。さっそく実行してみましょう。
mhiroi@DESKTOP-FQK6237:~/work/scm$ gosh -A . eight2.scm 31: 8 6 7 2 5 4 3 0 1 31: 6 4 7 8 5 0 3 2 1 1.8657366
最長手数は 31 手で、その配置は全部で 2 通りになります。実行時間は 1.87 秒でした。
●参考文献
- 井上うさぎ, 『世界のパズル百科イラストパズルワンダーランド』, 東京堂出版, 1997
- 三木太郎, 『特集コンピュータパズルへの招待 スライディングブロック編』, C MAGAZINE 1996 年 2 月号, ソフトバンク
●プログラムリスト３
;;;
;;; eight2.scm : 8 Puzzle の解法 (最長手数の探索)
;;;
;;; Copyright (C) 2008-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write) (scheme time)
(mylib hash))
;;; 盤面の大きさ
(define *size* 9)
;;; 隣接リスト
(define *adjacent*
#((1 3) ; 0
(0 2 4) ; 1
(1 5) ; 2
(0 4 6) ; 3
(1 3 5 7) ; 4
(2 4 8) ; 5
(3 7) ; 6
(4 6 8) ; 7
(5 7))) ; 8
;;; 局面の定義
(define-record-type State
(make-state board space move)
state?
(board get-board)
(space get-space)
(move get-move))
;;; 盤面の表示
(define (print-board board)
(let loop ((i 0))
(when
(< i *size*)
(display (vector-ref board i))
(display " ")
(if (or (= i 2) (= i 5) (= i 8)) (newline))
(loop (+ i 1))))
(newline))
;;; 解の表示
(define (print-answer state)
(display (get-move state))
(display ":\n")
(print-board (get-board state)))
;;; 駒の移動
(define (move-piece board space pos)
(let ((new-board (vector-copy board)))
(vector-set! new-board space (vector-ref new-board pos))
(vector-set! new-board pos 0)
new-board))
;;; ベクタの畳み込み
(define (vector-foldl fn a vec)
(vector-for-each (lambda (x) (set! a (fn a x))) vec)
a)
;;; ハッシュ関数
(define (hash-func board)
(vector-foldl (lambda (a x) (+ (* a *size*) x)) 0 board))
;;; 畳み込み
(define (foldl fn a xs)
(if (null? xs)
a
(foldl fn (fn a (car xs)) (cdr xs))))
;;; 最長手数の探索
(define (solver)
;; ハッシュ表
(define ht (make-hash-table 181499 hash-func equal?))
;; 幅優先探索
(define (bfs xs)
(let ((ys (foldl
(lambda (a st)
(let ((sp (get-space st))
(bd (get-board st)))
(foldl
(lambda (b x)
(let ((newbd (move-piece bd sp x)))
(cond
((hash-find ht newbd) b)
(else
(hash-set! ht newbd #t)
(cons (make-state newbd x (+ (get-move st) 1)) b)))))
a
(vector-ref *adjacent* sp))))
'()
xs)))
(if (pair? ys)
(bfs ys)
(for-each print-answer xs))))
;;
(let* ((start #(1 2 3 4 5 6 7 8 0))
(init-state (make-state start 8 0)))
(hash-set! ht start #t)
(bfs (list init-state))))
;;; 実行
(let ((s (current-jiffy)))
(solver)
(display (inexact (/ (- (current-jiffy) s) (jiffies-per-second))))
(newline))
改訂 2020 年 9 月 12 日