xyzzy Lisp Programming

簡易エキスパートシステムの作成 (5)

●番外編：変数の管理に束縛リストを使う方法

記号のパターンマッチング(2) では、ユニフィケーションを行うプログラムを 2 つ作りました。ひとつは変数の管理に「束縛リストを使う方法」で、もうひとつが「スペシャル変数を使う方法」です。今回作成した簡易エキスパートシステムは、変数の管理に「スペシャル変数を使う方法」を採用しました。ここでは番外編として、「束縛リストを使う方法」でプログラムを作ってみましょう。

今回のエキスパートシステムでは、変数は同じ節内でのみ有効です。したがって、変数は局所変数として扱われます。「スペシャル変数を使った変数の管理方法は、同じシンボルを異なる変数として扱うのには適していません。」と 簡易エキスパートシステムの作成 (2) で書きましたが、実は束縛リストを使う方法でも同じ問題点があるのです。

記号のパターンマッチング(2) で作成したユニフィケーションは、変数名（シンボル）が同じであれば節が異なっていても同じ変数として扱います。これは一般的なユニフィケーションでは当然のことなのですが、今回のようなエキスパートシステムとはあまり相性がよくありません。しかしながら、いまさらユニフィケーションを改造するのはちょっと面倒なので、ここでは今までの方法と同様に変数を新しいシンボルに置換することにします。

この場合、変数の値を求めるときに、束縛リストからシンボルを探索する処理が必要になります。したがって、その分だけスペシャル変数を使う方法よりも時間がかかると思われます。xyzzy Lisp で実行した場合、どの程度の差が出るのかちょっと興味があります。さっそく、プログラムを作ってみましょう。

●プログラムの改造

プログラムのポイントは「束縛リスト」の管理方法です。実行環境を保持する構造体 Env に束縛リストを保存することにします。次のリストを見てください。

List 1 : 実行環境の定義

(defstruct Env
  goal                 ; ゴール節
  rule-list            ; 述語に定義されている規則
  exec-rule            ; 実行中の規則
  exec-env             ; 作成した環境（スタックになる）
  binding              ; 束縛リスト
  prev-binding)        ; Env を作成したときの束縛リスト

構造体 Env に新しいスロット prev-binding を追加します。Env のオブジェクトを生成するとき、その時点で有効な束縛リストを prev-binding にセットし、この束縛リストを使ってユニフィケーションを行います。

ユニフィケーションが成功した場合、関数 unify は新しく束縛された変数を束縛リストに追加して返すので、それをスロット binding にセットします。再試行するときは、prev-binding の束縛リストを使うだけで、この環境で束縛された変数をクリアする（束縛リストから削除する）ことができます。

次は関数 make-env-obj を修正します。

List 2 : 実行環境の作成

(defun make-env-obj (pattern binding)
  (make-Env
   :goal         pattern
   :rule-list    (get (car pattern) 'RULE)
   :binding      'call
   :prev-binding binding))

引数 binding は環境を生成するときの束縛リストです。これをスロット prev-binding にセットします。

次は関数 exec-clause を修正します。

List 3 : 節の実行

(defun exec-clause (env)
  (let ((result 'fail))
    (if (eq (Env-binding env) 'call)
        ; 最初の呼び出し
        (if (Env-rule-list env)
            (setq result (select-rule env)))
        ; 再試行
        (if (eq 'fail (setq result (exec-body env)))
            ; 次の節を実行
            (setq result (select-rule env))))
    ; 結果を返す
    result))

失敗したときに変数束縛をクリアしていた処理を削除します。あとの処理は同じです。

次は関数 select-rule を修正します。

List 4 : 頭部と照合する規則を選択

(defun select-rule (env)
  (let ((result 'fail))
    (while (and (listp (setq result (unify-head env)))
                (Env-exec-rule env))
      ; 実行環境の生成
      (push (make-env-obj (car (Env-exec-rule env)) result)
            (Env-exec-env env))
      ; 体部の実行
      (setq result (exec-body env))
      (if (listp result) (return)))
    result))

unify-head は引数 env の prev-binding に格納されている束縛リストを使ってユニフィケーションを行います。ユニフィケーションが成功すると unify-head は新しい束縛リストを返すので、それを変数 result にセットします。体部を実行するときは make-env-obj に result を渡して新しい実行環境を生成します。

次は関数 unify-head を修正します。

List 5 : 頭部とのユニフィケーション

(defun unify-head (env)
  (let ((result 'fail) now-rule)
    (while (Env-rule-list env)
      ; 節をコピーする
      (setq now-rule (copy-clause (pop (Env-rule-list env))))
      ; 節の head と goal のユニフィケーション
      (setq result (unify (Env-goal env) (pop now-rule) (Env-prev-binding env)))
      (when (listp result)
        ; 成功
        (setf (Env-exec-rule env) now-rule
              (Env-binding env) result)
        (return)))
    result))

unify でユニフィケーションを行うとき、引数 env のスロット prev-binding の束縛リストを渡します。変数束縛をクリアする処理は必要ありません。

次は関数 exec-body を修正します。

List 6 : 体部の実行

(defun exec-body (env)
  (let ((max-state (length (Env-exec-rule env)))
        (result 'fail)
        now-state)
    (while (Env-exec-env env)
      (setq result (exec-clause (car (Env-exec-env env))))
      (cond
       ; 失敗したらバックトラック
       ((eq 'fail result) (pop (Env-exec-env env)))
       ; すべてのゴールが成功
       ((= max-state (setq now-state (length (Env-exec-env env))))
        (return))
       ; 次のゴールへ進む
       (t (push (make-env-obj (elt (Env-exec-rule env) now-state) result)
                (Env-exec-env env)))))
    result))

体部の実行環境を生成するとき、exec-clause の実行結果 (束縛リスト) result を make-env-obj に渡します。あとの処理は同じです。

次は質問を受け付ける関数 Q を修正します。

List 7 : 質問する

(defun Q (question)
  (let* ((rule (make-rule-obj question))
         (env  (make-env-obj (Rule-clause rule) nil))
         result)
    (while (listp (setq result (exec-clause env)))
      (dolist (var (Rule-var-list rule) (terpri))
        (format t "~A = ~A~%" var (variable-value var result))))))

変数 env はいちばん最初に生成される実行環境なので、束縛されている変数は存在しないことに注意してください。したがって、make-env-obj には空リスト (nil) を渡します。

最後に関数 variable-value を修正します。

List 8 : 変数の値を求める

(defun variable-value (var binding)
  (let (value)
    (loop
      (setq value (assoc var binding))
      (unless value (return var))
      (setq value (cdr value))
      (cond
        ((eq var value)
         (return value))
        ((variablep value)
         (setq var value))
        ((consp value)
         (return (replace-variable value binding)))
        (t (return value))))))

variable-value は引数の束縛リスト binding から変数の値を求めます。関数 assoc で binding から変数 var を探します。見つからない場合は未束縛なので var をそのまま返します。見つかった場合は cdr で値を取り出して変数 value にセットします。あとの処理は同じです。

これでプログラムの修正は終わりです。詳細は プログラムリスト をお読みくださいませ。

●実行結果

それでは実行してみましょう。順列を求める述語 perm を使って、「スペシャル変数を使う方法」と「束縛リストを使う方法」の実行時間を比較してみました。述語 perm と select のリストを示します。

List 9 : 要素の選択（再掲）

((select ?x (?x . ?l) ?l))
((select ?x (?y . ?l) (?y . ?z)) (select ?x ?l ?z))

List 10 : 順列を求める（再掲）

((perm nil nil))
((perm ?x (?z . ?l)) (select ?z ?x ?y) (perm ?y ?l))

テストは次に示す 3 通りのパターンで行いました。

A: (Q '(perm (a b c d) ?z)
B: (Q '(perm (a b c d e) ?z)
C: (Q '(perm (a b c d e f) ?z)

M.Hiroi のオンボロマシン (Pentium 166 MHz) で実行したところ、結果は次のようになりました。

予想通り「スペシャル変数を使う方法」の方が高速でしたが、その差はそれほど大きくありません。xyzzy Lisp のリスト操作は高速ですね。ユニフィケーションをエキスパートシステム向きに改造すると、もう少し速くなるかもしれません。興味のある方は挑戦してみてください。

●プログラムリスト

;
; expert_1.l : Prolog 風エキスパートシステム
;
;              変数の管理に束縛リストを使う方法
;
;              Copyright (C) 2003 Makoto Hiroi
;

; ********** 節の定義 **********

;
; 節（事実と規則）の定義
;
(defstruct Rule
  var-list        ; 変数リスト
  clause)         ; 節

;
; 節をコピーする
;
(defun copy-clause (rule)
  (sublis
   (if (Rule-var-list rule)
       (mapcar #'(lambda (var) (cons var (gensym "?"))) (Rule-var-list rule)))
   (Rule-clause rule)))

;
; Rule を作る
;
(defun make-rule-obj (clause)
  (make-Rule :var-list (collect-variable clause) :clause clause))


;
; 節の登録
;
(defun assert (clause)
  (check-clause clause)
  (let ((predicate (car (car clause))))
    (setf (get predicate 'RULE)
          (cons (make-rule-obj clause) (get predicate 'RULE)))))

;
; 節のチェック
;
(defun check-clause (clause)
  (dolist (x clause)
    (if (or (atom x)
            (variablep (car x))
            (not (symbolp (car x))))
        (error "節に述語がありません ~A~%" clause))))


; ********** 節の実行 **********

;
; 実行環境の定義
;
(defstruct Env
  goal                 ; ゴール節
  rule-list            ; 述語に定義されている規則
  exec-rule            ; 実行中の規則
  exec-env             ; 作成した環境（スタックになる）
  binding              ; 束縛リスト
  prev-binding)        ; Env を作成したときの束縛リスト

;
; 実行環境の作成
;
(defun make-env-obj (pattern binding)
  (make-Env
   :goal         pattern
   :rule-list    (get (car pattern) 'RULE)
   :binding      'call
   :prev-binding binding))

;
; 節の実行
;
(defun exec-clause (env)
  (let ((result 'fail))
    (if (eq (Env-binding env) 'call)
        ; 最初の呼び出し
        (if (Env-rule-list env)
            (setq result (select-rule env)))
        ; 再試行
        (if (eq 'fail (setq result (exec-body env)))
            ; 次の節を実行
          (setq result (select-rule env))))
    ; 結果を返す
    result))

;
; 頭部と照合する規則を選択
;
(defun select-rule (env)
  (let ((result 'fail))
    (while (and (listp (setq result (unify-head env)))
                (Env-exec-rule env))
      ; 実行環境の生成
      (push (make-env-obj (car (Env-exec-rule env)) result)
            (Env-exec-env env))
      ; 体部の実行
      (setq result (exec-body env))
      (if (listp result) (return)))
    result))

;
; 頭部とのユニフィケーション
;
(defun unify-head (env)
  (let ((result 'fail) now-rule)
    (while (Env-rule-list env)
      ; 節をコピーする
      (setq now-rule (copy-clause (pop (Env-rule-list env))))
      ; 節の head と goal のユニフィケーション
      (setq result (unify (Env-goal env) (pop now-rule) (Env-prev-binding env)))
      (when (listp result)
        ; 成功
        (setf (Env-exec-rule env) now-rule
              (Env-binding env) result)
        (return)))
    result))

;
; 体部の実行
;
(defun exec-body (env)
  (let ((max-state (length (Env-exec-rule env)))
        (result 'fail)
        now-state)
    (while (Env-exec-env env)
      (setq result (exec-clause (car (Env-exec-env env))))
      (cond
       ; 失敗したらバックトラック
       ((eq 'fail result) (pop (Env-exec-env env)))
       ; すべてのゴールが成功
       ((= max-state (setq now-state (length (Env-exec-env env))))
        (return))
       ; 次のゴールへ進む
       (t (push (make-env-obj (elt (Env-exec-rule env) now-state) result)
                (Env-exec-env env)))))
    result))


;
; ********** ユニフィケーション **********
;
; OUTPUT -- 失敗 : fail, 成功 : 束縛リスト
;
(defun unify (pattern datum binding)
  (cond ((variablep pattern)
         (unify-variable pattern datum binding))
        ((variablep datum)
         (unify-variable datum pattern binding))
        ((and (atom pattern) (atom datum))
         (unify-atoms pattern datum binding))
        ((and (consp pattern) (consp datum))
         (unify-pieces pattern datum binding))
        (t 'fail)))

;
; アトムとのユニフィケーション
;
(defun unify-atoms (pattern datum binding)
  (if (equal pattern datum) binding 'fail))

;
; リストのユニフィケーション
;
(defun unify-pieces (pattern datum binding)
  (let ((result (unify (car pattern) (car datum) binding)))
    (if (eq result 'fail)
        'fail
        (unify (cdr pattern) (cdr datum) result))))

;
; 変数とのユニフィケーション
;
(defun unify-variable (pattern datum binding)
  (let ((value (assoc pattern binding)))
    (if (and value
             (not (eq pattern (cdr value))))
        (unify (cdr value) datum binding)
        (add-binding pattern datum binding))))   ; insidep のチェックは不要


; ********** サブルーチン **********

;
; 変数をチェックする
; 
(defun variablep (pattern)
  (and (symbolp pattern)
       (char= #\? (char (string pattern) 0))))

;
; 変数束縛に追加する
;
(defun add-binding (var value binding)
  (cons (cons var value) binding))

;
; 節で使用されている変数を集める
;
(defun collect-variable (clause &optional var-list)
  (cond
    ((variablep clause)
     (pushnew clause var-list))
    ((atom clause) var-list)
    (t
      (collect-variable
        (cdr clause)
        (collect-variable (car clause) var-list)))))

;
; 変数を置換する
;
(defun replace-variable (pattern binding)
  (cond
    ((variablep pattern)
     (variable-value pattern binding))
    ((atom pattern) pattern)
    (t
     (cons (replace-variable (car pattern) binding)
           (replace-variable (cdr pattern) binding)))))

;
; 変数値を求める
;
(defun variable-value (var binding)
  (let (value)
    (loop
      (setq value (assoc var binding))
      (unless value (return var))
      (setq value (cdr value))
      (cond
        ((eq var value)
         (return value))
        ((variablep value)
         (setq var value))
        ((consp value)
         (return (replace-variable value binding)))
        (t (return value))))))

;
; データのロード : ((p ...) ... ) の形式
;
(defun load-data (filename)
  (let (clause)
    (with-open-file (in filename :direction :input)
      (while (setq clause (read in nil))
        (assert clause)))))

;
; 質問する
;
(defun Q (question)
  (let* ((rule (make-rule-obj question))
         (env  (make-env-obj (Rule-clause rule) nil))
         result)
    (while (listp (setq result (exec-clause env)))
      (dolist (var (Rule-var-list rule) (terpri))
        (format t "~A = ~A~%" var (variable-value var result))))))

ちょっと寄り道

■蛙跳びゲームを解く

今回はパズル「蛙跳びゲーム」を Common Lisp で解いてみましょう。それでは問題です。

黒石と白石を入れ替えるのがパズルの目的です。石を動かす規則は次のとおりです。

• 隣のマスが空いているならばそこに移動できる。
• 白石は黒石を、黒石は白石をひとつだけ跳び越して空き場所に移動できる。
• 黒石は右か下の方向にだけ、白石は左か上の方向にだけ移動できる。
• 斜め方向の移動や後戻りはできない。

この規則で黒石と白石を入れ替える最短手順を求めてください。

■幅優先探索で解く

今回は幅優先探索でプログラムを作ります。最初にキューの大きさを決めるため、局面の総数を求めます。マスは全部で 11 か所あるので、空き場所の配置は 11 通りあります。石の配置は、残り 10 か所に 5 個の黒石を配置するので ₁₀Ｃ₅ = 252 通りあります。局面の総数は 11 * 252 = 2772 通りになるので、キューの大きさは 2772 に設定します。もっとも、このパズルでは後戻りができないので、実際に現れる局面数はこれよりもずっと少なくなると思われます。同一局面のチェックは、とりあえず線形探索とします。

最初にデータ構造を定義しましょう。盤面はリストで表して、黒石をシンボル B, 白石をシンボル W, 空き場所をシンボル S で表します。盤面とリストの対応は下図を見てください。

石の移動方向を番号の大小関係でチェックするため、番号は左上から右下へ順番につけています。こうすると、黒石の移動は小さな番号から大きな番号、逆に白石の移動は大きな番号から小さな番号になります。

石の移動は隣接リストと跳び先表を用意すると簡単にプログラムできます。問題 (A) の隣接リストと跳び先表を List 11, 12 に示します。

List 11 : 隣接リスト

(setq *neighbor*
      #((2)        ; 0
        (2 4)      ; 1
        (0 1 5)    ; 2
        (4)        ; 3
        (1 3 5)    ; 4
        (2 4 6 8)  ; 5
        (5 7 9)    ; 6
        (6)        ; 7
        (5 9 10)   ; 8
        (6 8)      ; 9
        (8)))      ; 10  

List 12 : 跳び先表

(setq *jump-table*
      #(((5 . 2))                          ; 0
        nil                                ; 1
        ((8 . 5))                          ; 2
        ((5 . 4))                          ; 3
        ((6 . 5))                          ; 4
        ((0 . 2) (3 . 4) (7 . 6) (10 . 8)) ; 5
        ((4 . 5))                          ; 6
        ((5 . 6))                          ; 7
        ((2 . 5))                          ; 8
        nil                                ; 9
        ((5 . 8))))                        ; 10  

隣接リスト *neighbor* と石の跳び先表 *jump-table* はベクタで定義します。その要素はどちらもリストであることに注意してください。跳び先表は空き場所を基準にしていて、リストの要素は跳ぶ石の位置と跳び越される石の位置を格納したドット対です。たとえば、空き場所が 0 番の場合、5 番の石が 2 番の石を跳び越して 0 番へ移動することができます。このとき、石の種類をチェックすることをお忘れなく。

次は石を動かして新しい盤面を作る関数 make-new-board を作ります。次のリストを見てください。

List 13 : 石を動かして新しい盤面を作る

; 石を動かす
(defun move-stone (board space pos)
  (let ((new-board (copy-list board)))
    (setf (nth space new-board) (nth pos new-board)
          (nth pos new-board) 'S)
    ; 先頭に空き場所の位置をセット
    (cons pos new-board)))

; 移動方向のチェック
(defun move-p (board from to)
  (or (and (eq (nth from board) 'B) (< from to))
      (and (eq (nth from board) 'W) (< to from))))

; 新しい盤面を作る
(defun make-new-board (board space)
  (let (result from pos)
    ; 跳び越す場合
    (dolist (x (aref *jump-table* space))
      (setq from (car x)
            pos  (cdr x))
      (when (move-p board from space)
        (unless (eq (nth from board) (nth pos board))
          (push (move-stone board space from) result))))
    ; 空き場所へ動かす場合
    (dolist (x (aref *neighbor* space) result)
      (when (move-p board x space)
        (push (move-stone board space x) result)))))

関数 make-new-board の引数 board が盤面、space が空き場所の位置を表します。関数 move-p は石の移動方向 (form -> to) をチェックし、関数 move-stone は石を動かして新しい盤面を生成します。

make-new-board は、最初にほかの石を跳び越して移動する場合をチェックします。*jump-table* から跳ぶ石の位置と跳び越される石の位置を取り出して、変数 from と pos にセットします。関数 move-p で移動方向をチェックし、from と pos にある石の種類が異なっていれば跳び越すことができます。関数 move-stone で石を動かして新しい盤面を生成し、それをリスト (result) に格納します。

次に、隣の空き場所へ石を移動する場合をチェックします。*neighbor* から空き場所の隣の位置を取り出して変数 x にセットします。あとは move-p で移動方向をチェックするだけです。

関数 move-stone は copy-list で盤面 board をコピーして、それを setf で破壊的に修正しています。なお、リストの先頭に空き場所の位置をセットしていることに注意してください。

あとは単純な幅優先探索なので説明は省略します。詳細は プログラムリスト をお読みくださいませ。

■実行結果

それでは実行結果を下図に示します。図では黒石を B, 白石を W, 空き場所を S で表しています。

  0:
      B      
    B B      
  B B S W W  
      W W    
      W      

  1:           2:           3:           4:           5:           6:
      B            B            B            B            B            B      
    B B          B S          B W          B W          B W          B W      
  B B W W W    B B W W W    B B S W W    B B W S W    B S W B W    S B W B W  
      S W          B W          B W          B W          B W          B W    
      W            W            W            W            W            W      

  7:           8:           9:           10:          11:          12:
      B            B            B            B            B            B      
    B W          B W          B W          B W          B W          B W      
  W B S B W    W B W B W    W B W B W    W B W B W    W B W S W    W S W B W  
      B W          B W          S W          W S          W B          W B    
      W            S            B            B            B            B      

  13:          14:          15:          16:          17:          18:
      B            B            B            B            B            B      
    S W          W S          W W          W W          W W          W W      
  W B W B W    W B W B W    W B S B W    W B W B S    W B W S B    W S W B B  
      W B          W B          W B          W B          W B          W B    
      B            B            B            B            B            B      

  19:          20:          21:          22:          23:
      B            S            W            W            W      
    W W          W W          W S          W W          W W      
  W W S B B    W W B B B    W W B B B    W W B B B    W W S B B  
      W B          W B          W B          S B          B B    
      B            B            B            B            B      

                  図 3 : 問題 (A) の解答 (23 手)

実行時間は M.Hiroi のオンボロマシン (Pentium 166 MHz) で約 1.7 秒でした。同一局面のチェックは線形探索ですが、生成された局面数が 1154 個と少なかったので、それほど時間はかかりませんでした。スタートとゴールの双方向から探索するか、ハッシュ法など高速な探索アルゴリズムを使うともっと速くなるでしょう。

問題 (B) のプログラムはベクタ *jump-table* と *neighbor* を変更し、盤面を表示する関数 print-board を修正するだけです。興味のある方はプログラムを作ってみてください。

■プログラムリスト

;
; kaeru_a.l : 蛙跳びゲーム（変形版）
;
;             Copyright (C) 2003 Makoto Hiroi
;

;
; ***** 問題 (A) *****
;
;     ０         Ｂ
;   １２       ＢＢ
; ３４５６７ ＢＢＳＷＷ
;     ８９       ＷＷ
;     10         Ｗ
;

; 隣接リスト
(setq *neighbor*
      #((2)        ; 0
        (2 4)      ; 1
        (0 1 5)    ; 2
        (4)        ; 3
        (1 3 5)    ; 4
        (2 4 6 8)  ; 5
        (5 7 9)    ; 6
        (6)        ; 7
        (5 9 10)   ; 8
        (6 8)      ; 9
        (8)))      ; 10  

; 跳び先表 : 空き場所が基準で (跳ぶ駒  . 跳び越される駒)
(setq *jump-table*
      #(((5 . 2))                          ; 0
        nil                                ; 1
        ((8 . 5))                          ; 2
        ((5 . 4))                          ; 3
        ((6 . 5))                          ; 4
        ((0 . 2) (3 . 4) (7 . 6) (10 . 8)) ; 5
        ((4 . 5))                          ; 6
        ((5 . 6))                          ; 7
        ((2 . 5))                          ; 8
        nil                                ; 9
        ((5 . 8))))                        ; 10


; 石を動かす
(defun move-stone (board space pos)
  (let ((new-board (copy-list board)))
    (setf (nth space new-board) (nth pos new-board)
          (nth pos new-board) 'S)
    ; 先頭に空き場所の位置をセット
    (cons pos new-board)))


; 移動方向のチェック
(defun move-p (board from to)
  (or (and (eq (nth from board) 'B) (< from to))
      (and (eq (nth from board) 'W) (< to from))))


; 新しい盤面を作る
(defun make-new-board (board space)
  (let (result from pos)
    ; 跳び越す場合
    (dolist (x (aref *jump-table* space))
      (setq from (car x)
            pos  (cdr x))
      (when (move-p board from space)
        (unless (eq (nth from board) (nth pos board))
          (push (move-stone board space from) result))))
    ; 空き場所へ動かす場合
    (dolist (x (aref *neighbor* space) result)
      (when (move-p board x space)
        (push (move-stone board space x) result)))))


; 盤面を表示
(defun print-board (board)
  (apply #'format t "    ~S ~%  ~S ~S~%~S ~S ~S ~S ~S~%    ~S ~S~%    ~S~%~%"
         board))


; 手順を表示
(defun print-answer (n state prev)
  (if (plusp n)
      (print-answer (aref prev n) state prev))
  (print-board (cdr (aref state n))))


; 幅優先探索による解法
(defun solve (start goal)
  (let ((state (make-array 2772))
        (prev  (make-array 2772))
        (front 0)
        (rear 1))
    ; 初期化
    (setf (aref state 0) (cons (position 'S start) start)
          (aref prev  0) -1)
    (while (< front rear)
      (let ((board (aref state front)))
        ; new-board の先頭要素は空き場所の位置
        (dolist (new-board (make-new-board (cdr board) (car board)))
          (unless (find new-board state :end rear :test #'equal)
            ; 新しい局面
            (setf (aref state rear) new-board
                  (aref prev  rear) front)
            ; ゴールに到達したか
            (when (equal goal (cdr new-board))
              (format t "局面数 ~D~%" (1+ rear))
              (print-answer rear state prev)
              (return-from solve t))
            ; キューに登録
            (incf rear))))
      (incf front))))