今回は「箱入り娘」という有名なスライドパズルを解いてみましょう。次の図を見てください。
[問題] スライドパズル「箱入り娘」
┌─┬───┬─┐ ┌───────┐ │父│ │母│ │ │ │ │ 娘 │ │ │ │ │親│ │親│ │ │ ├─┼───┼─┤ │ │ │下│番 頭│下│ │ │ │ ├─┬─┤ │ │ ┌───┐ │ │男│小│小│女│ │ │ │ │ ├─┼─┼─┼─┤ │ │ 娘 │ │ │小│ │ │小│小:小僧 │ │ │ │ └─┴─┴─┴─┘ └─┴───┴─┘ 出口 出口 START GOAL
箱入り娘は一番大きな駒 (2 * 2) である「娘」を出口から取り出すパズルです。盤面の大きさは 4 * 5 で、駒は娘のほかに 2 * 1 が 1 つ、1 * 2 が 4 つ、1 * 1 が 4 つあります。START から GOAL (娘を出口へ連れ出す) までの最短手数を求めてください。GOAL の状態で、他の駒はどこに配置にされていてもかまいません。なお、同じ駒を連続して動かす場合は 1 手と数えることにします。
今回は幅優先探索でプログラムを作りましょう。盤面は大きさ 20 のベクタで表します。次の図を見てください。
0 1 2 3 M1 L1 L2 M1 4 * 4 : L1, L2, L2, L2 4 5 6 7 M2 L2 L2 M2 2 * 1 : N1, N2 8 9 10 11 M1 N1 N2 M1 1 * 2 : M1, M2 12 13 14 15 M2 O O M2 1 * 1 : O 16 17 18 19 O S S O 空き : S 盤面 STARTの局面 図 : 盤面と駒の定義
娘 (4 * 4) はシンボル L1 と L2 で、番頭 (2 * 1) は N1 と N2 で表します。父親、母親、下男、下女は同じ大きさの駒 (1 * 2) で、GOAL 状態での配置に条件がないので区別する必要はありません。M1 と M2 で表すことにします。小僧 (1 * 1) は 0 で表します。大駒の移動は 1 を付けたシンボルを基点にして行うことにします。
駒の移動は簡単です。たとえば、L1 と L2 を上へ移動する関数 move-l1-up は次のようになります。
リスト : L1, L2 の移動 (defun move-l1-up (board x) (let ((x1 (- x 4)) (x2 (- x 3))) (if (and (<= 0 x1) (eq (aref board x1) 'S) (eq (aref board x2) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'L1 (aref new-board x2) 'L2 (aref new-board x) 'L2 (aref new-board (+ x 1)) 'L2 (aref new-board (+ x 4)) 'S (aref new-board (+ x 5)) 'S) (values new-board x1)))))
引数 x は L1 の位置を表します。上へ動かす場合、L1 は x - 4 の位置へ移動します。その位置を変数 x1 に、右隣の L2 の位置を x2 にセットします。そして、x1 が盤面の範囲内にあり、x1 と x2 が空き場所 (S) であれば、駒を移動することができます。
駒を動かす場合、最初に盤面 board を関数 copy-seq でコピーして変数 new-board にセットします。そして、x1 と x2 の位置に L1 と L2 を、x と x + 1 の位置に L2 をセットします。それから、x + 4 と x + 5 の位置に S をセットして、new-board と L1 の新しい位置 x1 を values で返します。新しい駒の位置 x1 は駒を連続して動かすときに使います。
駒の移動に関しては、とくに難しいところはありません。詳細は プログラムリスト をお読みください。
次は幅優先探索で使用するキューとハッシュ表を定義します。
リスト : キューとハッシュ表 (defvar *queue* (make-queue)) (defvar *table* (make-hash-table :test 'equalp))
キューは拙作のページ Common Lisp 入門 リストの破壊的修正 で作成したキューと同じです。関数はキューを生成する make-queue, データを追加する enqueue, データを取り出す dequeue のほかに、キューが空かチェックする queue-emptyp とキューを空にする queue-clear を追加しています。
キューは make-queue で生成して、変数 *queue* にセットします。ハッシュ表は関数 make-hash-table で生成して、変数 *table* にセットします。キーはベクタ (盤面) になるので、キーワード :test にはシンボル equalp を指定します。ハッシュ表の使い方は拙作のページ Common Lisp 入門 ハッシュ表 をお読みください。
幅優先探索で「箱入り娘」を解くプログラムは次のようになります。
リスト : 幅優先探索による箱入り娘の解法 ; 駒の移動関数 (defvar *move-list* `((L1 ,#'move-l1-up ,#'move-l1-down ,#'move-l1-left ,#'move-l1-right) (M1 ,#'move-m1-up ,#'move-m1-down ,#'move-m1-left ,#'move-m1-right) (N1 ,#'move-n1-up ,#'move-n1-down ,#'move-n1-left ,#'move-n1-right) (O ,#'move-o-up ,#'move-o-down ,#'move-o-left ,#'move-o-right))) ; 幅優先探索 (defun solve (start goalp) (enqueue *queue* (list start 0 nil)) (setf (gethash start *table*) t) (do () ((queue-emptyp *queue*)) (let ((state (dequeue *queue*))) (if (funcall goalp (car state)) (progn (print-answer state) (return)) (dotimes (x 20) (move-piece (car state) x (cdr (assoc (aref (car state) x) *move-list*)) state t))))))
関数 slove の引数 start は START を表すベクタで、goalp はゴールに到達したか調べる述語です。キューには局面を表すリストを格納します。リストの要素は (盤面 手数 直前の局面) です。最初に初期状態の局面をキューに、盤面をハッシュ表に登録します。それから、do ループでキューから局面を取り出して、駒を移動させて新しい盤面を生成します。
まず最初に、取り出した局面 state にある盤面がゴールに到達したか goalp を呼び出してチェックします。そうであれば、関数 print-answer で手順を表示して、return で do ループから脱出します。そうでなければ、関数 move-piece を呼び出して駒を移動します。
move-peice の第 3 引数には駒の移動関数を格納したリストを渡します。関数は連想リストに格納して変数 *move-list* にセットしておきます。dotimes で盤面の要素を順番に取り出して、assoc で *move-list* を探索します。見つかった場合は、駒の移動関数を格納したリストが move-piece に渡されます。見つからない場合、assoc は nil を返すので、move-piece には nil が渡されます。
最後に関数 move-piece を作ります。次のリストを見てください。
リスト : 駒を移動する (defun move-piece (board x move state flag) (dolist (fn move) (multiple-value-bind (new-board x1) (funcall fn board x) (when new-board (unless (gethash new-board *table*) (setf (gethash new-board *table*) t) (enqueue *queue* (list new-board (1+ (second state)) state))) (when flag ; 連続移動は 1 手と数える (move-piece new-board x1 move state nil))))))
引数 board が盤面、x が移動する駒の位置、move は移動関数を格納したリスト、state は局面です。flag が t の場合は同じ駒を続けて動かします。まず dolist で move から移動関数を順番に取り出して fn にセットします。funcall で fn を評価して、返り値を new-board と x1 で受け取ります。new-board が nil でなければ、駒を動かすことができたので、ハッシュ表で同一の盤面がないかチェックします。新しい盤面であれば、キューとハッシュ表に登録します。
次に flag が t の場合は同じ駒を続けて動かすことができるかチェックします。これは move-piece を再帰呼び出しするだけです。このとき、move-piece に渡す盤面は new-board で、位置は x1 になります。なお、同一の盤面がすでにある場合でも、同じ駒を連続移動することで、新しい盤面が生成されることがあります。このため、ハッシュ表に同一の盤面がある場合でも、連続移動のチェックは必要になります。ご注意ください。
あとのプログラムは簡単なので説明は割愛いたします。詳細は プログラムリスト をお読みください。
プログラムは次のように実行します。
(solve *q00* #'(lambda (x) (eq (aref x 13) 'L1)))
*q00* は START の盤面 (ベクタ) を格納した変数です。結果は次のようになりました。
0: M1 L1 L2 M1 M2 L2 L2 M2 M1 N1 N2 M1 M2 O O M2 O S S O 1: 2: 3: 4: 5: 6: M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M1 N1 N2 M1 M1 N1 N2 M1 M1 N1 N2 S M1 S N1 N2 S M1 N1 N2 S M1 N1 N2 M2 S O M2 M2 S O M2 M2 S O M1 M2 S O M1 S M2 O M1 O M2 O M1 O O S O O O O S O O O M2 O O O M2 O O O M2 S O O M2 7: 8: 9: 10: 11: 12: M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 S M1 N1 N2 S S N1 N2 N1 N2 S S N1 N2 S O N1 N2 O O N1 N2 O O O M2 O M1 O M1 O M1 O M1 O M1 O M1 S M1 O M1 S M1 O S M1 M1 O S O M2 O M2 O M2 O M2 O M2 O M2 O M2 O M2 S M2 O S M2 M2 13: 14: 15: 16: 17: 18: M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 N1 N2 O O S S O O O S S O O O S S O O M1 S O O M1 M1 S S M1 M1 N1 N2 M1 M1 N1 N2 M1 M1 N1 N2 M1 M1 N1 N2 M2 M1 N1 N2 M2 M2 O O M2 M2 O O M2 M2 O O M2 M2 O O M2 M2 O O S M2 O O S S 19: 20: 21: 22: 23: 24: M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 O O M1 M1 O O M1 M1 O O M1 M1 O S M1 M1 O M1 S M1 O M1 M1 S N1 N2 M2 M2 N1 N2 M2 M2 S S M2 M2 O S M2 M2 O M2 S M2 O M2 M2 S O S S O S S O O N1 N2 O O N1 N2 O O N1 N2 O O N1 N2 O O 25: 26: 27: 28: 29: 30: M1 L1 L2 S M1 S L1 L2 S M1 L1 L2 O M1 L1 L2 O M1 L1 L2 O M1 L1 L2 M2 L2 L2 S M2 S L2 L2 S M2 L2 L2 S M2 L2 L2 O M2 L2 L2 O M2 L2 L2 O M1 M1 M1 O M1 M1 M1 O M1 M1 M1 S M1 M1 M1 S M1 M1 M1 M1 S M1 M1 O M2 M2 M2 O M2 M2 M2 O M2 M2 M2 O M2 M2 M2 S M2 M2 M2 M2 S M2 M2 N1 N2 O O N1 N2 O O N1 N2 O O N1 N2 O O N1 N2 O O N1 N2 O O 31: 32: 33: 34: 35: 36: O S L1 L2 O L1 L2 S O L1 L2 M1 O L1 L2 M1 O L1 L2 M1 O L1 L2 M1 O S L2 L2 O L2 L2 S O L2 L2 M2 O L2 L2 M2 O L2 L2 M2 O L2 L2 M2 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 S M1 M1 S M1 M1 M1 O M1 M1 M1 O M1 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 S M2 M2 S M2 M2 M2 S M2 M2 M2 O M2 N1 N2 O O N1 N2 O O N1 N2 O O N1 N2 O O N1 N2 S O N1 N2 S S 37: 38: 39: 40: 41: 42: O L1 L2 M1 O L1 L2 M1 O L1 L2 M1 O L1 L2 M1 O S S M1 S S O M1 O L2 L2 M2 O L2 L2 M2 O L2 L2 M2 O L2 L2 M2 O L1 L2 M2 O L1 L2 M2 M1 M1 O M1 S M1 O M1 S S O M1 O S S M1 O L2 L2 M1 O L2 L2 M1 M2 M2 O M2 M1 M2 O M2 M1 M1 O M2 M1 M1 O M2 M1 M1 O M2 M1 M1 O M2 S S N1 N2 M2 S N1 N2 M2 M2 N1 N2 M2 M2 N1 N2 M2 M2 N1 N2 M2 M2 N1 N2 43: 44: 45: 46: 47: 48: S O O M1 O O O M1 O O O M1 O O O M1 O O O M1 O O O M1 S L1 L2 M2 S L1 L2 M2 M1 L1 L2 M2 M1 L1 L2 M2 M1 L1 L2 M2 M1 S S M2 O L2 L2 M1 S L2 L2 M1 M2 L2 L2 M1 M2 L2 L2 M1 M2 L2 L2 M1 M2 L1 L2 M1 M1 M1 O M2 M1 M1 O M2 S M1 O M2 M1 S O M2 M1 S S M2 M1 L2 L2 M2 M2 M2 N1 N2 M2 M2 N1 N2 S M2 N1 N2 M2 S N1 N2 M2 O N1 N2 M2 O N1 N2 49: 50: 51: 52: 53: 54: O O S M1 O O M1 S O O M1 M1 O O M1 M1 O O M1 M1 O S M1 M1 M1 O S M2 M1 O M2 S M1 O M2 M2 M1 O M2 M2 M1 S M2 M2 M1 O M2 M2 M2 L1 L2 M1 M2 L1 L2 M1 M2 L1 L2 S M2 S L1 L2 M2 O L1 L2 M2 O L1 L2 M1 L2 L2 M2 M1 L2 L2 M2 M1 L2 L2 S M1 S L2 L2 M1 S L2 L2 M1 S L2 L2 M2 O N1 N2 M2 O N1 N2 M2 O N1 N2 M2 O N1 N2 M2 O N1 N2 M2 O N1 N2 55: 56: 57: 58: 59: 60: S O M1 M1 M1 O M1 M1 M1 O M1 M1 M1 O M1 M1 M1 O M1 M1 M1 O M1 M1 M1 O M2 M2 M2 O M2 M2 M2 O M2 M2 M2 O M2 M2 M2 O M2 M2 M2 O M2 M2 M2 O L1 L2 S O L1 L2 M1 O L1 L2 M1 O L1 L2 M1 S L1 L2 M1 L1 L2 S M1 S L2 L2 M1 S L2 L2 M2 S L2 L2 M2 S L2 L2 M2 S L2 L2 M2 L2 L2 S M2 O N1 N2 M2 O N1 N2 S O N1 N2 O S N1 N2 O O N1 N2 O O N1 N2 61: 62: 63: 64: 65: 66: M1 O M1 S M1 O S M1 M1 S O M1 M1 S O M1 S M1 O M1 M1 M1 O M1 M2 O M2 S M2 O S M2 M2 O S M2 M2 S O M2 S M2 O M2 M2 M2 O M2 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 M1 L1 L2 M1 S L1 L2 M1 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 M2 L2 L2 M2 S L2 L2 M2 O O N1 N2 O O N1 N2 O O N1 N2 O O N1 N2 O O N1 N2 O O N1 N2 67: 68: 69: 70: 71: 72: M1 M1 O M1 M1 M1 O M1 M1 M1 S M1 M1 M1 M1 S M1 M1 M1 M1 M1 M1 M1 M1 M2 M2 O M2 M2 M2 S M2 M2 M2 S M2 M2 M2 M2 S M2 M2 M2 M2 M2 M2 M2 M2 L1 L2 S M1 L1 L2 S M1 L1 L2 O M1 L1 L2 O M1 L1 L2 O S L1 L2 O O L2 L2 S M2 L2 L2 O M2 L2 L2 O M2 L2 L2 O M2 L2 L2 O S L2 L2 S S O O N1 N2 O O N1 N2 O O N1 N2 O O N1 N2 O O N1 N2 O O N1 N2 73: 74: 75: 76: 77: 78: M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 L1 L2 O O L1 L2 O O L1 L2 O O S S O O O S S O O O S S L2 L2 N1 N2 L2 L2 N1 N2 L2 L2 N1 N2 L1 L2 N1 N2 L1 L2 N1 N2 L1 L2 N1 N2 O O S S O S S O S S O O L2 L2 O O L2 L2 O O L2 L2 O O 79: 80: 81: M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M1 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 M2 O O N1 N2 O O N1 N2 O O N1 N2 L1 L2 S S L1 L2 S O S L1 L2 O L2 L2 O O L2 L2 S O S L2 L2 O
最短手数は 81 手、生成された局面数は 23962 通り、実行時間は Windows XP, celeron 1.40 GHz, SBCL ver 1.0.29 で約 0.7 秒でした。箱入り娘の局面数は思っていたよりも少ないようで、高速に解くことができましたが、人手で解くのは難しいパズルだと思いました。
箱入り娘は駒の種類、配置、ゴールの位置で難易度が大きく変化します。プログラムリストの変数 *q02* に 98 手の問題を、*q03* には「ダットパズル」と呼ばれる 59 手の問題を用意しました。興味のある方はいろいろ試してみてください。
; ; hako.l : 箱入り娘 ; ; Copyright (C) 2010 Makoto Hiroi ; ;;; キューの定義 (defstruct queue (front nil) (rear nil)) ; データを入れる (defun enqueue (q item) (let ((new-cell (list item))) (if (queue-front q) ; 最終セルを書き換える (setf (cdr (queue-rear q)) new-cell) ; キューは空の状態 (setf (queue-front q) new-cell)) (setf (queue-rear q) new-cell))) ; データを取り出す (defun dequeue (q) (when (queue-front q) (prog1 (pop (queue-front q)) (unless (queue-front q) ; キューは空になった (setf (queue-rear q) nil))))) ; 空か? (defun queue-emptyp (q) (null (queue-front q))) ; クリア (defun queue-clear (q) (setf (queue-front q) nil (queue-rear q) nil)) ;;; 駒の移動 ; 盤面はベクタ (4 * 6) ; ; 0 1 2 3 M1 L1 L2 M1 ; 4 5 6 7 M2 L2 L2 M2 ; 8 9 10 11 M1 N1 N2 M1 ; 12 13 14 15 M2 O O M2 ; 16 17 18 19 O S S O ; L1, L2 の移動 (defun move-l1-up (board x) (let ((x1 (- x 4)) (x2 (- x 3))) (if (and (<= 0 x1) (eq (aref board x1) 'S) (eq (aref board x2) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'L1 (aref new-board x2) 'L2 (aref new-board x) 'L2 (aref new-board (+ x 1)) 'L2 (aref new-board (+ x 4)) 'S (aref new-board (+ x 5)) 'S) (values new-board x1))))) (defun move-l1-down (board x) (let ((x1 (+ x 8)) (x2 (+ x 9))) (if (and (< x1 20) (eq (aref board x1) 'S) (eq (aref board x2) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'L2 (aref new-board x2) 'L2 (aref new-board (+ x 4)) 'L1 (aref new-board (+ x 5)) 'L2 (aref new-board x) 'S (aref new-board (+ x 1)) 'S) (values new-board (+ x 4)))))) (defun move-l1-right (board x) (let ((x1 (+ x 2)) (x2 (+ x 6))) (if (and (/= (mod x1 4) 0) (eq (aref board x1) 'S) (eq (aref board x2) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'L2 (aref new-board x2) 'L2 (aref new-board (+ x 1)) 'L1 (aref new-board (+ x 5)) 'L2 (aref new-board x) 'S (aref new-board (+ x 4)) 'S) (values new-board (+ x 1)))))) (defun move-l1-left (board x) (let ((x1 (- x 1)) (x2 (+ x 3))) (if (and (/= (mod x1 4) 3) (eq (aref board x1) 'S) (eq (aref board x2) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'L1 (aref new-board x2) 'L2 (aref new-board x) 'L2 (aref new-board (+ x 4)) 'L2 (aref new-board (+ x 1)) 'S (aref new-board (+ x 5)) 'S) (values new-board x1))))) ; M1, M2 の移動 (defun move-m1-up (board x) (let ((x1 (- x 4))) (if (and (<= 0 x1) (eq (aref board x1) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'M1 (aref new-board x) 'M2 (aref new-board (+ x 4)) 'S) (values new-board x1))))) (defun move-m1-down (board x) (let ((x1 (+ x 8))) (if (and (< x1 20) (eq (aref board x1) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'M2 (aref new-board (+ x 4)) 'M1 (aref new-board x) 'S) (values new-board (+ x 4)))))) (defun move-m1-right (board x) (let ((x1 (+ x 1)) (x2 (+ x 5))) (if (and (/= (mod x1 4) 0) (eq (aref board x1) 'S) (eq (aref board x2) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'M1 (aref new-board x2) 'M2 (aref new-board x) 'S (aref new-board (+ x 4)) 'S) (values new-board x1))))) (defun move-m1-left (board x) (let ((x1 (- x 1)) (x2 (+ x 3))) (if (and (/= (mod x1 4) 3) (eq (aref board x1) 'S) (eq (aref board x2) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'M1 (aref new-board x2) 'M2 (aref new-board x) 'S (aref new-board (+ x 4)) 'S) (values new-board x1))))) ; N1, N2 の移動 (defun move-n1-up (board x) (let ((x1 (- x 4)) (x2 (- x 3))) (if (and (<= 0 x1) (eq (aref board x1) 'S) (eq (aref board x2) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'N1 (aref new-board x2) 'N2 (aref new-board x) 'S (aref new-board (+ x 1)) 'S) (values new-board x1))))) (defun move-n1-down (board x) (let ((x1 (+ x 4)) (x2 (+ x 5))) (if (and (< x1 20) (eq (aref board x1) 'S) (eq (aref board x2) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'N1 (aref new-board x2) 'N2 (aref new-board x) 'S (aref new-board (+ x 1)) 'S) (values new-board x1))))) (defun move-n1-right (board x) (let ((x1 (+ x 2))) (if (and (/= (mod x1 4) 0) (eq (aref board x1) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'N2 (aref new-board (+ x 1)) 'N1 (aref new-board x) 'S) (values new-board (+ x 1)))))) (defun move-n1-left (board x) (let ((x1 (- x 1))) (if (and (/= (mod x1 4) 3) (eq (aref board x1) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'N1 (aref new-board x) 'N2 (aref new-board (+ x 1)) 'S) (values new-board x1))))) ; O の移動 (defun move-o-up (board x) (let ((x1 (- x 4))) (if (and (<= 0 x1) (eq (aref board x1) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'O (aref new-board x) 'S) (values new-board x1))))) (defun move-o-down (board x) (let ((x1 (+ x 4))) (if (and (< x1 20) (eq (aref board x1) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'O (aref new-board x) 'S) (values new-board x1))))) (defun move-o-right (board x) (let ((x1 (+ x 1))) (if (and (/= (mod x1 4) 0) (eq (aref board x1) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'O (aref new-board x) 'S) (values new-board x1))))) (defun move-o-left (board x) (let ((x1 (- x 1))) (if (and (/= (mod x1 4) 3) (eq (aref board x1) 'S)) (let ((new-board (copy-seq board))) (setf (aref new-board x1) 'O (aref new-board x) 'S) (values new-board x1))))) ; 盤面の表示 (defun print-board (board) (do ((x 0 (1+ x))) ((<= 20 x) (terpri)) (format t "~2A " (aref board x)) (if (= (mod x 4) 3) (terpri)))) ; 手順の表示 (defun print-answer (state) (if (consp (third state)) (print-answer (third state))) (format t "~D:~%" (second state)) (print-board (first state))) ; 駒の移動関数 (defvar *move-list* `((L1 ,#'move-l1-up ,#'move-l1-down ,#'move-l1-left ,#'move-l1-right) (M1 ,#'move-m1-up ,#'move-m1-down ,#'move-m1-left ,#'move-m1-right) (N1 ,#'move-n1-up ,#'move-n1-down ,#'move-n1-left ,#'move-n1-right) (O ,#'move-o-up ,#'move-o-down ,#'move-o-left ,#'move-o-right))) ; キューとハッシュ (defvar *queue* (make-queue)) (defvar *table* (make-hash-table :test 'equalp)) ; 駒を移動する (defun move-piece (board x move state flag) (dolist (fn move) (multiple-value-bind (new-board x1) (funcall fn board x) (when new-board (unless (gethash new-board *table*) (setf (gethash new-board *table*) t) (enqueue *queue* (list new-board (1+ (second state)) state))) (when flag ; 連続移動は 1 手と数える (move-piece new-board x1 move state nil)))))) ; 幅優先探索 (defun solve (start goalp) (enqueue *queue* (list start 0 nil)) (setf (gethash start *table*) t) (do () ((queue-emptyp *queue*)) (let ((state (dequeue *queue*))) (if (funcall goalp (car state)) (progn (print-answer state) (return)) (dotimes (x 20) (move-piece (car state) x (cdr (assoc (aref (car state) x) *move-list*)) state t)))))) ; 箱入り娘 : 81 手, goal L1 = 13 (defvar *q01* #(M1 L1 L2 M1 M2 L2 L2 M2 M1 N1 N2 M1 M2 O O M2 O S S O)) ; 箱入り娘 : 98 手, goal L1 = 13 (defvar *q02* #(M1 L1 L2 M1 M2 L2 L2 M2 O N1 N2 O N1 N2 N1 N2 O S S O)) ; ダットパズル : 59 手, goal L1 = 12 (defvar *q03* #(L1 L2 N1 N2 L2 L2 N1 N2 O O S S M1 M1 N1 N2 M2 M2 N1 N2))