3.10 8パズルと2つの後者関数

AIMA lisp

今回は完全な探索関数の作成ではなく、2種類の後者関数を実装して比較する課題である。作るのは

  1. 状態をコピーし、それを修正することで一度にすべての後者を生成するもの
  2. 呼び出されるたびに状態を直接修正することで逐次後者を生成するもの

の2種類だ。8パズルがどのようなものかを示すと、

#12
345
678

という順番に番号が書かれたピースが並んでいて、空白(#)の隣にあるピースを順次動かすことで問題を作り、元の状態に戻させるパズルである。空白が1ピース分しかないことがこのスライディングブロックパズルの肝なので、ピースの個数は8個に限らず、3個でも15個でも何個でもよい。


このパズルの状態はピースの配置であり、後者は空白の隣のピースを一つ動かすことで生成できる。まずは初期状態を作る関数を作ろう。

(defvar *goal*)
(defvar *state*)

(defun shuffle (lst)
  (let ((l (copy-seq lst))
        (len (1+ (length lst)))
        res)
    (while (plusp (decf len))
      (push (nthpop (random len) l) res))
    res))

(defun nthpop (x lst)
  (let* ((l (nthcdr x lst))
         (r (car l)))
    (rplaca l (cadr l))
    (rplacd l (cddr l))
    r))

(defun do-init (x &optional (y x))
  (let (l1 l2)
    (dotimes (a (* x y))
      (push (intern (format nil "a~A" a)) l1)
      (push (intern (format nil "s~A" a)) l2))
    (setq *goal* (pairlis l1 l2))
    (setq *state* (pairlis l1 (shuffle l2)))))

;8パズルの初期状態(一例)
(do-init 3)
|((a0 . s5) (a1 . s0) (a2 . s8) (a3 . s1) (a4 . s3) (a5 . s7) (a6 . s4) (a7 . s6) (a8 . s2))

(format t "~{~A ~A ~A~%~A ~A ~A~%~A ~A ~A~%~}"
        (mapcar 'car (stable-sort (copy-seq state) 'string< :key 'cdr)))
| a5 a2 a7
| a1 a0 a4
| a6 a3 a8

goal
|((a0 . s0) (a1 . s1) (a2 . s2) (a3 . s3) (a4 . s4) (a5 . s5) (a6 . s6) (a7 . s7) (a8 . s8))

ピースをメインに考えているので、ピース(aX)の並び順固定で場所(sY)を入れ替えている。配置を見るのはやや面倒ではあるが、探索するときにはちょっとだけ楽が出来る。空白(a0)は常に先頭にあるので、これはわざわざ探さなくて済む。ちなみに、ピースを順次移動させるのではなく、ランダムに並び替えて初期状態を作っているので、解が存在しないパターンが出てくる。この場合はいつまでも探索していても解が見つからないので注意が必要だ。


次に、ある位置にある空白にどこのピースが移動できるかを記述する。コードでルールを直書きしても良いが、汎用性のために経路を書き下す。具体的には、道をつくる - xyzzysims制作中 - 人工知能一般で書いた関数がそのまま使える。

(setq 2x2path (make-grid-path '((s0 s1)(s2 s3))))
|((s0 . s1) (s1 . s0) (s0 . s2) (s2 . s0) (s2 . s3) (s3 . s2) (s1 . s3) (s3 . s1))

(setq 3x3path (make-grid-path '((s0 s1 s2)(s3 s4 s5)(s6 s7 s8))))
|(省略)

これで経路に従ってピースを移動させれば良い。

(defun next-state (state move-to)
  "空白の移動"
  (rotatef (cdar state) (cdr (rassoc move-to state)))
  state)

(defun next-states (state path)
  "後者関数１"
  (let ((mover (remove-if-not (lambda (x) (eq x (cdar state))) path :key 'car)))
    (mapcar (lambda (x) (next-state (copy-tree state) (cdr x))) mover)))

(defun move-state (state path)
  "後者関数２"
  (let ((mover (member (cdar state) path :key 'car)))
    (if mover (next-state state (cdar mover)))
    mover))

(defun unmove-state (state path)
  "後者関数２の後退"
  (next-state state (caar path)))

*state*
|((a0 . s0) (a1 . s2) (a2 . s3) (a3 . s1))

(next-states *state* 2x2path)
|(((a0 . s1) (a1 . s2) (a2 . s3) (a3 . s0))
/ ((a0 . s2) (a1 . s0) (a2 . s3) (a3 . s1)))

(setq cur-path (move-state *state* 2x2path))
|((s0 . s1) (s1 . s0) (s0 . s2) (s2 . s0) (s2 . s3) (s3 . s2) (s1 . s3) (s3 . s1))

*state*
|((a0 . s1) (a1 . s2) (a2 . s3) (a3 . s0))

(unmove-state *state* cur-path)
|((a0 . s0) (a1 . s2) (a2 . s3) (a3 . s1))

1番目の方は、1手先を全部作ってリストで返す。2番目の方は状態と利用した経路を返すべきだが、状態は書き換えてしまうので手抜きをして経路のみ返している。戻るときは返り値の最初を逆に適用し、次を探すときは返り値の頭を除いて適用すればよい。


このように後者関数の返り値の形が異なるので、1番目は再帰関数で、2番目はループ関数にするのがいいだろう。課題の要求により、どちらも反復深化深さ優先探索を用いる。

(defun show-depth (depth)
  "経過表示用"
  (format t "~A~[th~;st~;nd~;rd~:;th~] depth~%"
              depth depth (refresh-screen) (do-events)))

;再帰型
(defun solve-recursive (state goal path expander)
  (labels ((sub (state lapse)
             (if (zerop lapse)
                 (if (equal goal state) (list state))
               (dolist (s (funcall expander state path))
                 (let ((res (sub s (1- lapse))))
                   (if res (return (cons state res))))))))
    (do ((depth 0 (1+ depth))
         (result nil (sub state depth)))
        (result result)
      (show-depth depth))))

;ループ型
(defun solve-step-by-step (state goal path next previous)
  (do ((depth 0) (cur-depth 0)
       (mover) (cur-mover))
      ((equal goal state)
       (let ((l (list (copy-tree state))))
         (dolist (cur-mover mover l)
           (funcall previous state cur-mover)
           (push (copy-tree state) l))))
    (while (setq cur-mover (pop mover))
      (funcall previous state cur-mover)
      (let ((next-mover (funcall next state (cdr cur-mover))))
        (if next-mover (return (push next-mover mover))
          (decf cur-depth))))
    (unless cur-mover
      (show-depth (incf depth)))
    (while (> depth cur-depth)
      (push (funcall next state path) mover)
      (incf cur-depth))))

;試験用の初期状態
(do-init 2)
|((a0 . s0) (a1 . s2) (a2 . s3) (a3 . s1))

(solve-recursive *state* *goal* 2x2path 'next-states)
|0th depth
|1st depth
|2nd depth
|3rd depth
|4th depth
|(((a0 . s0) (a1 . s2) (a2 . s3) (a3 . s1))
/ ((a0 . s2) (a1 . s0) (a2 . s3) (a3 . s1))
/ ((a0 . s3) (a1 . s0) (a2 . s2) (a3 . s1))
/ ((a0 . s1) (a1 . s0) (a2 . s2) (a3 . s3))
/ ((a0 . s0) (a1 . s1) (a2 . s2) (a3 . s3)))

(solve-step-by-step *state* *goal* 2x2path 'move-state 'unmove-state)
|1st depth
|2nd depth
|3rd depth
|4th depth
/(((a0 . s0) (a1 . s2) (a2 . s3) (a3 . s1))
/ ((a0 . s2) (a1 . s0) (a2 . s3) (a3 . s1))
/ ((a0 . s3) (a1 . s0) (a2 . s2) (a3 . s1))
/ ((a0 . s1) (a1 . s0) (a2 . s2) (a3 . s3))
/ ((a0 . s0) (a1 . s1) (a2 . s2) (a3 . s3)))

見ての通り、再帰型の方が単純に書ける。do記法にぴったり合っている。doで回しているのは、再帰関数がdepthごとに探索を終えるためだ。depthが決まれば、各段ごとに枝を展開し、末端で解を見つければ状態を返しながら戻ってくる。ループ型の方はかなり複雑である。状態は一つしか記憶しないので、かわりに、探索した経路を記録して、末端を調べたら経路を参照して状態を戻し、次の枝を探して奥へ進む、といった動作をしている。複雑ではあるが、調べる度に状態全体をコピーしない分動作は速い。


試験では、ループ型の方は"0th depth"を表示していないが、これは表示タイミングの問題なだけでちゃんと調べている。それを除けば、出力結果は同様である。


今回は8パズルという題であったが、3パズルで試した。実は、今回の探索関数では遅すぎて、8パズルの解を探すまでに非常に時間がかかってしまうのだ。また、初期状態から解があるかどうかわからないので、長い間計算を続けていても不毛な場合があり、時間をかけて探索するのは無駄が多いのだ。次は初期状態を調べて解があるかどうかを判定する関数を作ってみよう。