パズルに挑戦！
●問題４「スライドパズル」の解答
それでは 問題４「スライドパズル」 の解法プログラムを作りましょう。最初は幅優先探索で、次に反復深化を使って解いてみます。スライドパズルの盤面はリストを使って表します。リストと盤面の対応は下図を見てください。
●幅優先探索で解く
これから作成する幅優先探索のプログラムは、スタートとゴールの双方向から探索し、同一局面のチェックにはハッシュ法を使います。最初にキューの大きさを決めましょう。このスライドパズルは数字ではなく 6 種類の駒 (┘┐┌└│─) を使っています。─と│は 2 個ずつあるので、局面の総数は次のようになります。
9 * 8 * 7 * 6 * 5 * 4Ｃ2 * 2Ｃ2 = 9 * 8 * 7 * 6 * 5 * 6 * 1 = 90720
キューの大きさは 90720 とします。それから、同一局面のチェックにハッシュ法を使うので、駒は次のように数値で表すことにします。
0: 空き場所 1: ┌ 2: ─ 3: ┐ 4: │ 5: └ 6: ┘
あとは 幅優先探索とスライドパズル で作成した「6 パズル」の解法プログラムとほぼ同じです。ただし、駒を動かして新しい局面を作る関数 move-piece は、駒─と│が 2 個ずつあるため、そのままでは使うことができません。move-piece は作り直すことにします。次のプログラムを見てください。
List 1 : 駒を動かす
(defun move-piece (space pos board)
(let ((new-board (copy-seq board)))
(setf (nth space new-board) (nth pos board)
(nth pos new-board) 0)
new-board))
引数 space が空き場所の位置、pos が動かす駒の位置、board が局面を表すリストです。move-piece には駒の種類ではなく、位置を渡すことに注意してください。最初に copy-seq でリストをコピーします。それから、setf で pos にある駒を space にセットし、pos の位置に 0 をセットします。今回はリストを破壊的に修正しましたが、再帰定義でもプログラムを作ることができます。興味のある方は試してみてください。
次はハッシュ法のプログラムを作ります。
List 2 : ハッシュ法
; 初期化 (19997 は素数)
(defun init-hash ()
(setq *myhash* (make-array 19997)))
; ハッシュ値の計算
(defun hash-value (state)
(let ((value 0))
(dolist (x state (mod value 19997))
(setq value (+ (* value 10) x)))))
; ハッシュ表に挿入
(defun insert-hash (state num)
(let* ((value (hash-value state))
(item (find state (aref *myhash* value) :key #'cdr :test #'equal)))
(if (null item)
(progn
(push (cons num state) (aref *myhash* value))
nil)
(car item))))
今回のプログラムはスタートとゴールの双方向から探索するため、同一局面の有無だけではなく見つけた局面の番号を返すようにします。そこで、ハッシュ表に局面（リスト）を格納するとき、リストの先頭に局面の番号を付け加えることにします。
関数 insert-hash はハッシュ表にデータを挿入します。引数 state が局面を表すリストで、num がその局面の番号を表します。関数 hash-value で state のハッシュ値を求め、関数 find でハッシュ表から state を検索します。このとき、キーワード :key に cdr を、:test に equal を指定することに注意してください。これでリストの先頭要素はデータの検索から除外されます。
同じ局面が見つからなければ、ハッシュ表に state を登録します。このとき、state の先頭に num を追加します。progn を使っているのは nil を返すためです。同じ局面を見つけた場合は、car で先頭要素（番号）を返します。
あとはとくに難しいところはないでしょう。詳細は プログラムリスト１ をお読みくださいませ。
●実行結果
それでは実行結果を示します。空き場所は □ で表しています。
最小手数は 30 手になりました。実は、GOAL から最長手数となる局面が START なのです。生成した局面数は 14560 個、実行時間は M.Hiroi のオンボロマシン (Pentium 166 MHz) で約 9 秒でした。スタートとゴールの双方向からの探索とハッシュ法の効果は十分に出ていると思います。
ちなみに、最長手数の局面は全部で次の 6 通りあります。
生成した局面数は 90720 個になりました。しがたって、 このパズルは駒をランダムに配置しても、必ずゴールに到達できることがわかります。実行時間ですが、 M.Hiroi のオンボロマシン (Pentium 166 MHz) では約 2 分かかりました。興味のある方は プログラムリスト２ をお読みくださいませ。
プログラムリスト１（幅優先探索）
プログラムリスト２（最長手数の局面を求める）
●反復深化で解く
次は反復深化で解いてみましょう。このパズルは手数が長いので「下限値枝刈り法」を使います。下限値を求める方法ですが、ちょっと寄り道「反復深化と下限値枝刈り法」 で説明した「移動手数」を採用します。ただし、今回のパズルは同じ駒が複数あるので、この方法をそのまま適用することはできません。次の図を見てください。
駒 │ に注目してください。3 番と 5 番は正しい位置なので、移動手数は 0 でいいですね。│ が 0 番にある場合、3 番に移動すれば 1 手ですが 5 番に移動すれば 3 手かかります。この場合は短い方の手数を移動手数とします。このとき、もうひとつの駒 │ が 3 番にある場合は 5 番へ移動しなければいけませんが、それでも移動手数は 1 手とします。つまり、もうひとつの駒の位置を考慮しないで移動手数を求めるのです。下限値の精度は低下しますが、そのかわりプログラムは簡単になります。
移動手数は 2 次元配列 *distance* に格納します。
List 3 : 移動手数
(defvar *distance* #2A((0 0 0 0 0 0 0 0 0) ; 0 dummy
(0 1 2 1 2 3 2 3 4) ; 1
(1 0 1 2 1 2 1 0 1) ; 2
(2 1 0 3 2 1 4 3 2) ; 3
(1 2 1 0 1 0 1 2 1) ; 4
(2 3 4 1 2 3 0 1 2) ; 5
(4 3 2 3 2 1 2 1 0))) ; 6
あとは ちょっと寄り道「反復深化と下限値枝刈り法」 で作成したプログラムとほとんど同じです。ただし、同じ駒を続けて動かさないようにチェックする処理を修正します。次のリストを見てください。
List 4 : 下限値枝刈り法による反復深化
(defun solve-id-low (n limit board goal space history low)
(if (= limit n)
(when (equal board goal)
(print-answer board history)
(throw 'find-answer t))
(dolist (pos (aref *adjacent* space))
(let ((piece (nth pos board)) new-low)
(unless (eql pos (cdar history))
(setq new-low (+ low (- (aref *distance* piece space)
(aref *distance* piece pos))))
(if (<= (+ new-low n) limit)
(solve-id-low (1+ n) limit (move-piece space pos board)
goal pos (cons (cons pos space) history) new-low)))))))
「6 パズル」では、1 手前の駒を続けて動かさないようにするため駒の種類をチェックしました。ところが、今回のパズルは同じ駒が複数あるため、この方法を適用することはできません。そこで、駒の移動元と移動先の位置を履歴 history に格納して、動かす駒の位置でチェックすることにします。
隣接リストから動かす駒の位置を求めて変数 pos にセットします。history の要素はドット対 (移動元の位置 . 移動先の位置) です。pos が 1 手前の移動先の位置 (cadr history) と同じであれば、同じ駒を続けて動かすことになります。この場合は pos の駒を動かしません。
あとはとくに難しいところはないでしょう。詳細は プログラムリスト３ をお読みくださいませ。
●実行結果
さっそく実行してみたところ、当然ですが最短手数は 30 手で実行時間は M.Hiroi のオンボロマシン (Pentium 166 MHz) で約 43 秒でした。幅優先探索に比べると、反復深化はやっぱり時間がかかりますね。それに下限値の精度も低いので、実行時間が遅いのはしょうがないでしょう。下限値を工夫するともう少し速くなるかもしれません。興味のある方は挑戦してみてください。
●プログラムリスト１
;
; eight_b.l : 変形版「８パズル」の解法（幅優先探索）
;
; Copyright (C) 2002 Makoto Hiroi
;
; 隣接リスト
(defvar *adjacent* #((1 3) ; 0
(0 4 2) ; 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
; キューの定義
(defconstant *SIZE* 90720) ; キューのサイズ
(defvar *state* (make-array *SIZE*)) ; 局面を格納するベクタ
(defvar *prev* (make-array *SIZE*)) ; ひとつ前の局面の番号
(defvar *space* (make-array *SIZE*)) ; 空白の位置
(defvar *direction* (make-array *SIZE*)) ; 探索の方向
; 駒を動かす（リストはコピーされる）
(defun move-piece (space pos board)
(let ((new-board (copy-seq board)))
(setf (nth space new-board) (nth pos board)
(nth pos new-board) 0)
new-board))
; 盤面の表示
(defun print-board (board)
(let ((code '("□" "┌" "─" "┐" "│" "└" "┘")))
(dotimes (x 9)
(if (zerop (mod x 3)) (terpri))
(format t "~A" (nth (nth x board) code)))
(terpri)))
; 解の表示
(defun print-answer-forward (pos)
(if (/= pos 0)
(print-answer-forward (aref *prev* pos)))
(print-board (aref *state* pos)))
(defun print-answer-backward (pos)
(while (/= pos -1)
(print-board (aref *state* pos))
(setq pos (aref *prev* pos))))
(defun print-answer1 (p1 p2)
(cond ((eq (aref *direction* p1) 'forward)
(print-answer-forward p1)
(print-answer-backward p2))
(t (print-answer-forward p2)
(print-answer-backward p1))))
; ***** ハッシュ法（19997 は素数）*****
; 初期化
(defun init-hash ()
(setq *myhash* (make-array 19997)))
; ハッシュ値の計算
(defun hash-value (state)
(let ((value 0))
(dolist (x state (mod value 19997))
(setq value (+ (* value 10) x)))))
; ハッシュ表に挿入
(defun insert-hash (state num)
(let* ((value (hash-value state))
(item (find state (aref *myhash* value) :key #'cdr :test #'equal)))
(if (null item)
(progn
(push (cons num state) (aref *myhash* value))
nil)
(car item))))
; 幅優先探索 (start, goal 双方向からの探索)
(defun solve-b (start goal)
(let ((rear 2) (front 0))
; 初期化
(setf (aref *state* 0) start
(aref *prev* 0) -1
(aref *space* 0) (position 0 start)
(aref *direction* 0) 'forward
(aref *state* 1) goal
(aref *prev* 1) -1
(aref *space* 1) (position 0 goal)
(aref *direction* 1) 'backward)
; ハッシュ表の初期化
(init-hash)
(insert-hash start 0)
(insert-hash goal 1)
;
(while (< front rear)
(let ((space (aref *space* front))
(board (aref *state* front)) new-board x)
(dolist (pos (aref *adjacent* space))
(setq new-board (move-piece space pos board))
; 同一局面のチェック
(setq x (insert-hash new-board rear))
(cond ((null x)
; キューに書き込む
(setf (aref *state* rear) new-board
(aref *space* rear) pos
(aref *prev* rear) front
(aref *direction* rear) (aref *direction* front))
(incf rear))
((not (eq (aref *direction* x) (aref *direction* front)))
; 発見
(print-answer1 front x)
(print rear)
(return-from solve-b)))))
(incf front))))
; 変形版「８パズル」の解法
(defun eight-puzzle ()
(solve-b '(6 4 5 2 0 2 3 4 1) '(1 2 3 4 0 4 5 2 6)))
●プログラムリスト２
;
; eight_max.l : 変形版「８パズル」の解法
; 最長手数の局面を求める
;
; Copyright (C) 2002 Makoto Hiroi
;
; 隣接リスト
(defvar *adjacent* #((1 3) ; 0
(0 4 2) ; 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
; キューの定義
(defconstant *SIZE* 90720) ; キューのサイズ
(defvar *state* (make-array *SIZE*)) ; 局面を格納するベクタ
(defvar *space* (make-array *SIZE*)) ; 空白の位置
(defvar *move* (make-array *SIZE*)) ; 手数
; 駒を動かす（リストはコピーされる）
(defun move-piece (space pos board)
(let ((new-board (copy-seq board)))
(setf (nth space new-board) (nth pos board)
(nth pos new-board) 0)
new-board))
; 盤面の表示
(defun print-board (board)
(let ((code '("□" "┌" "─" "┐" "│" "└" "┘")))
(dotimes (x 9)
(if (zerop (mod x 3)) (terpri))
(format t "~A" (nth (nth x board) code)))
(terpri)))
; 最長手数の局面を表示
(defun print-answer-max (pos)
(let ((max-move (aref *move* pos)))
(format t "~%最長手数 ~D 手" max-move)
(while (= max-move (aref *move* pos))
(print-board (aref *state* pos))
(decf pos))))
; ***** ハッシュ法（19997 は素数）*****
; 初期化
(defun init-hash ()
(setq *myhash* (make-array 19997)))
; ハッシュ値の計算
(defun hash-value (state)
(let ((value 0))
(dolist (x state (mod value 19997))
(setq value (+ (* value 10) x)))))
; ハッシュ表に挿入
(defun insert-hash (state)
(let* ((value (hash-value state))
(item (find state (aref *myhash* value) :test #'equal)))
(if (null item)
(push state (aref *myhash* value)))))
; 変形版「８パズル」の最長手数を求める
(defun solve-max ()
(let ((start '(1 2 3 4 0 4 5 2 6))
(rear 1) (front 0))
; 初期化
(setf (aref *state* 0) start
(aref *move* 0) 0
(aref *space* 0) (position 0 start))
(init-hash)
(insert-hash start)
;
(while (< front rear)
(let ((space (aref *space* front))
(board (aref *state* front))
new-board)
(dolist (pos (aref *adjacent* space))
(setq new-board (move-piece space pos board))
; 同一局面のチェック
(when (insert-hash new-board)
; キューに書き込む
(setf (aref *state* rear) new-board
(aref *space* rear) pos
(aref *move* rear) (1+ (aref *move* front)))
(incf rear))))
(incf front))
; 解の表示
(format t "局面の総数 ~D~%" rear)
(print-answer-max (1- rear))))
●プログラムリスト３
;
; eight_id.l : 変形版「８パズル」の解法（反復深化＋下限値枝刈り法）
;
; Copyright (C) 2002 Makoto Hiroi
;
; 隣接リスト
(defvar *adjacent* #((1 3) ; 0
(0 4 2) ; 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
; 移動手数
(defvar *distance* #2A((0 0 0 0 0 0 0 0 0) ; 0 dummy
(0 1 2 1 2 3 2 3 4) ; 1
(1 0 1 2 1 2 1 0 1) ; 2
(2 1 0 3 2 1 4 3 2) ; 3
(1 2 1 0 1 0 1 2 1) ; 4
(2 3 4 1 2 3 0 1 2) ; 5
(4 3 2 3 2 1 2 1 0))) ; 6
; 駒を動かす（リストはコピーされる）
(defun move-piece (space pos board)
(let ((new-board (copy-seq board)))
(setf (nth space new-board) (nth pos board)
(nth pos new-board) 0)
new-board))
; 盤面の表示
(defun print-board (board)
(let ((code '("□" "┌" "─" "┐" "│" "└" "┘")))
(dotimes (x 9)
(if (zerop (mod x 3)) (terpri))
(format t "~A" (nth (nth x board) code)))
(terpri)))
; 解の表示
(defun print-answer (board history)
(if history
; 履歴をたどって盤面を再現する
(print-answer (move-piece (caar history) (cdar history) board)
(cdr history)))
(print-board board))
; 下限値の計算
(defun calc-distance (board)
(let ((value 0))
(dotimes (x 9 value)
(incf value (aref *distance* (pop board) x)))))
; 下限値枝刈り法 (history は (pos . space) を格納する)
(defun solve-id-low (n limit board goal space history low)
(if (= limit n)
(when (equal board goal)
(print-answer board history)
(throw 'find-answer t))
(dolist (pos (aref *adjacent* space))
(let ((piece (nth pos board)) new-low)
(unless (eql pos (cdar history))
(setq new-low (+ low (- (aref *distance* piece space)
(aref *distance* piece pos))))
(if (<= (+ new-low n) limit)
(solve-id-low (1+ n) limit (move-piece space pos board)
goal pos (cons (cons pos space) history) new-low)))))))
(defun eight-puzzle-low (start goal)
(catch 'find-answer
(let ((low (calc-distance start)))
(do ((x low (1+ x)))
((> x 31))
(format t "~%----- ~D 手の探索 -----" x)
(solve-id-low 0 x start goal (position 0 start) nil low)))))
; 変形版「８パズル」の解法
(defun eight-puzzle ()
(eight-puzzle-low '(6 4 5 2 0 2 3 4 1) '(1 2 3 4 0 4 5 2 6)))