M.Hiroi's Home Page

Common Lisp Programming

お気楽 Common Lisp プログラミング入門

[ PrevPage | Common Lisp | NextPage ]

箱入り娘

今回は「箱入り娘」という有名なスライドパズルを解いてみましょう。次の図を見てください。

[問題] スライドパズル「箱入り娘」

箱入り娘は一番大きな駒 (2 * 2) である「娘」を出口から取り出すパズルです。盤面の大きさは 4 * 5 で、駒は娘のほかに 2 * 1 が 1 つ、1 * 2 が 4 つ、1 * 1 が 4 つあります。START から GOAL (娘を出口へ連れ出す) までの最短手数を求めてください。GOAL の状態で、他の駒はどこに配置にされていてもかまいません。なお、同じ駒を連続して動かす場合は 1 手と数えることにします。

●盤面と駒の定義

今回は幅優先探索でプログラムを作りましょう。盤面は大きさ 20 のベクタで表します。次の図を見てください。

娘 (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))
初版 2010 年 9 月 19 日
改訂 2023 年 7 月 16 日
Copyright (C) 2010-2023 Makoto Hiroi
All rights reserved.
[ PrevPage | Common Lisp | NextPage ]