今回は「箱入り娘」という有名なスライドパズルを解いてみましょう。次の図を見てください。
[問題] スライドパズル「箱入り娘」
┌─┬───┬─┐ ┌───────┐
│父│ │母│ │ │
│ │ 娘 │ │ │ │
│親│ │親│ │ │
├─┼───┼─┤ │ │
│下│番 頭│下│ │ │
│ ├─┬─┤ │ │ ┌───┐ │
│男│小│小│女│ │ │ │ │
├─┼─┼─┼─┤ │ │ 娘 │ │
│小│ │ │小│小:小僧 │ │ │ │
└─┴─┴─┴─┘ └─┴───┴─┘
出口 出口
ＳＴＡＲＴ ＧＯＡＬ
箱入り娘は一番大きな駒 (2 * 2) である「娘」を出口から取り出すパズルです。盤面の大きさは 4 * 5 で、駒は娘のほかに 2 * 1 が 1 つ、1 * 2 が 4 つ、1 * 1 が 4 つあります。START から GOAL (娘を出口へ連れ出す) までの最短手数を求めてください。GOAL の状態で、他の駒はどこに配置にされていてもかまいません。なお、同じ駒を連続して動かす場合は 1 手と数えることにします。
今回は幅優先探索でプログラムを作りましょう。盤面は大きさ 20 のベクタで表します。次の図を見てください。
０ １ ２ ３ M1 L1 L2 M1 4 * 4 : L1, L2, L2, L2
４ ５ ６ ７ M2 L2 L2 M2 2 * 1 : N1, N2
８ ９ 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 *q01* (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 通り、実行時間は SBCL 2.1.11, Ubunts 22.04 (WSL2), Intel Core i5-6200U 2.30GHz で約 0.15 秒でした。箱入り娘の局面数は思っていたよりも少ないようで、高速に解くことができましたが、人手で解くのは難しいパズルだと思いました。
箱入り娘は駒の種類、配置、ゴールの位置で難易度が大きく変化します。プログラムリストの変数 *q02* に 98 手の問題を、*q03* には「ダットパズル」と呼ばれる 59 手の問題を用意しました。興味のある方はいろいろ試してみてください。
;;;
;;; hako.lisp : 箱入り娘
;;;
;;; Copyright (C) 2010-2023 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))