「lisp勉強１１日目パズルペグ・ソリテア・スターをLispで解く」の編集履歴（バックアップ）一覧はこちら
追加された行は緑色になります。
削除された行は赤色になります。
http://www.geocities.jp/m_hiroi/xyzzy_lisp/abclisp24.html
リンク先にはＬｉｓｐでペグ・ソリテア・スターというパズルを解くコードがあったので自分なりに読解。
同サイト記載のユニフィケーションによる簡易エキスパートシステムは、まだユニフィケーションのコードを何とか読解したレベル。
そこから構築される推論を実行できるコードの実行手順が意外と複雑なのでまだ手が出ない。
今のところ書いてあるＬｉｓｐコードを何とか読解できるけど、何かの問題を解くコードを自分で一からＬｉｓpプログラムで書けと言われたら四苦八苦するのは目に見えている。
(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);この関数ペグを一手動かしてるだけ、ｎが1ずつ増加し、posは移動先飛び越し先移動元の３つが入っている、
(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
http://www.geocities.jp/m_hiroi/xyzzy_lisp/abclisp24.html
リンク先にはＬｉｓｐでペグ・ソリテア・スターというパズルを解くコードがあったので自分なりに読解。
同サイト記載のユニフィケーションによる簡易エキスパートシステムは、まだユニフィケーションのコードを何とか読解したレベル。
そこから構築される推論を実行できるコードの実行手順が意外と複雑なのでまだ手が出ない。
今のところ書いてあるＬｉｓｐコードを何とか読解できるけど、何かの問題を解くコードを自分で一からＬｉｓpプログラムで書けと言われたら四苦八苦するのは目に見えている。
(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);この関数ペグを一手動かしてるだけ、ｎが1ずつ増加し、posは移動先飛び越し先移動元の３つが入っている、
(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
