※上記の広告は60日以上更新のないWIKIに表示されています。更新することで広告が下部へ移動します。

http://www.geocities.jp/m_hiroi/xyzzy_lisp/abclisp24.html
リンク先にはLispでペグ・ソリテア・スターというパズルを解くコードがあったので自分なりに読解。
同サイト記載のユニフィケーションによる簡易エキスパートシステムは、まだユニフィケーションのコードを何とか読解したレベル。
そこから構築される推論を実行できるコードの実行手順が意外と複雑なのでまだ手が出ない。
今のところ書いてあるLispコードを何とか読解できるけど、何かの問題を解くコードを自分で一からLispプログラムで書けと言われたら四苦八苦するのは目に見えている。



(defvar *jump-table*  #(((2 . 5) (3 . 7))            ; 0
                       ((2 . 3) (5 . 9))            ; 1
                       ((3 . 4) (5 . 8) (6 . 10))   ; 2
                       ((2 . 1) (6 . 9) (7 . 11))   ; 3
                       ((3 . 2) (7 . 10))           ; 4
                       ((2 . 0) (6 . 7) (9 . 12))   ; 5
                       nil                          ; 6
                       ((3 . 0) (6 . 5) (10 . 12))  ; 7
                       ((5 . 2) (9 . 10))           ; 8
                       ((5 . 1) (6 . 3) (10 . 11))  ; 9
                       ((6 . 2) (7 . 4) (9 . 8))    ; 10
                       ((7 . 3) (10 . 9))           ; 11
                       ((9 . 5) (10 . 7))))         ; 12			
*jump-table*
(defun get-lower-value (board from)
 (let ((value 0))
   (dolist (c '(0 1 4 8 11 12) value);最低何手必要か予測する
     (if (and (not (eql c from)) (nth c board));コーナーにペグがあり今選択中のペグ出ないなら
  (incf value)))));一手足す
get-lower-value
(defun move-peg (n board pos);この関数ペグを一手動かしてるだけ、nが1ずつ増加し、posは移動先飛び越し先移動元の3つが入っている、
 (if board;ボードが空リストでないなら
     (cons (if (member n pos);ペグを動かしたマスなら
	(not (car board));boardを反転して返す
      (car board));if文終わり、
    (move-peg (1+ n) (cdr board) pos))));consで(car board)と(move-peg)の戻り値を結合する
(defun get-move-pattern (board)
 (let (result del to)
   (dotimes (from 13 result);nマス目で動かせるものがあるか
     (when (nth from board);boardのfrom個目がnilになってないならペグがそこにある
(dolist (pos (aref *jump-table* from));fromマスから動かせる方向のリストをjump-tableから取得
  (setq del (car pos);delマスが飛び越されるマス
	to (cdr pos));posが飛び越された先
  (if (and (nth del board) (not (nth to board)));delにペグがあり,toにペグがないなら
      (push (list from del to) result)))))));動かせる動かし方リストに追加して次の動かし方をチェックする
get-move-pattern
(defun print-answer (history)
 (let ((prev (third (car history))))
   (format t "[~D, ~D" (first (car history)) prev);初手を表示
   (dolist (pos (cdr history));初手を除いたその後の手のリストを一つずつ取り出す
     (cond ((= prev (first pos))
     ;同じコマが跳んでいる
     (setq prev (third pos))
     (format t ",~D" prev))
    (t ;違うコマが跳ぶ
     (setq prev (third pos))
     (format t "][~D,~D" (first pos) prev))))
   (format t "]~%")
   (throw 'find-answer t)))
print-answer
(defun solve-id (n jc limit goal board history)
 (when (<= (+ jc (get-lower-value board (third (car history)))) limit);今の手数jc+予測された最小手数がlimitを上回らないなら次へ進める
   (if (= n 11)
(if (nth goal board);答えに到達
    (print-answer (reverse history)));答えの標示
     (dolist (pattern (get-move-pattern board));可能な全移動パタンのリストを求める
(solve-id (1+ n);ここからsolve-id関数の呼び出し開始
	  (if (eql (third (car history)) (first pattern));同じペグを動かすなら手数は増えない
	      jc
	    (1+ jc))
	  limit
	  goal
	  (move-peg 0 board pattern);boardにはpatternに入ってる動かし方で変更した結果がかえる
	  (cons pattern history))))));移動履歴をhistoryに追加 solve-id関数の再帰呼び出しはここまで
solve-id
(defun solve-peg-star (pos)
 (let ((board (make-list 13 :initial-element t)))
   (setf (nth pos board) nil)
   (catch 'find-answer;答えが見つかったらここに即座に戻る
     (do ((limit (get-lower-value board pos) (1+ limit)))
  ((> limit 10))
(format t "-----~D手を探索------~%" limit)
(solve-id 0 0 limit pos board nil)))));探索実行
solve-peg-star
(solve-peg-star 2)
-----6手を探索------
-----7手を探索------
[8, 2][12,5][11,9][4,10,8][1,9][0,5,7][8,10,4,2]
t