パズル「ペグ・ソリテア」解法プログラム
●12 穴盤のプログラムリスト
;
; peg12.l : ペグ・ソリテア 12 穴盤の解法（反復深化）
;
; Copyright (C) 2002 Makoto Hiroi
;
; 跳び先表 (跳び越される位置 . 跳び先の位置)
(defvar *jump-table* #(((2 . 5) (3 . 7)) ; 0
((3 . 6) (4 . 8)) ; 1
((3 . 4) (6 . 10)) ; 2
((6 . 9) (7 . 11)) ; 3
((3 . 2) (7 . 10)) ; 4
((2 . 0) (6 . 7)) ; 5
((3 . 1) (7 . 8)) ; 6
((3 . 0) (6 . 5)) ; 7
((4 . 1) (7 . 6)) ; 8
((6 . 3) (10 . 11)) ; 9
((6 . 2) (7 . 4)) ; 10
((7 . 3) (10 . 9)))) ; 11
; ペグの移動パターンをすべて求める
(defun get-move-pattern (board)
(let (result del to)
(dotimes (from 12 result)
(when (nth from board)
(dolist (pos (aref *jump-table* from))
(setq del (car pos)
to (cdr pos))
(if (and (nth del board) (not (nth to board)))
(push (list from del to) result)))))))
; ペグを動かす
(defun move-peg (n board pattern)
(if board
(cons (if (member n pattern)
(not (car board))
(car board))
(move-peg (1+ n) (cdr board) pattern))))
; 反復深化
(defun solve-id (n jc limit board history)
(when (<= jc limit)
(if (= n 10)
; 解を見つけた
(print-answer (reverse history))
; ペグを移動する
(dolist (pattern (get-move-pattern board))
(solve-id (1+ n)
; 連続跳び越しのチェック
(if (eql (third (car history)) (first pattern))
jc
(1+ jc))
limit
(move-peg 0 board pattern)
(cons pattern history))))))
; 解を表示する
(defun print-answer (history)
(let ((prev (third (car history))))
; 初手を表示
(format t "[~D, ~D" (first (car history)) prev)
; 2 手目以降を表示
(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 "]~%")
(incf *count*)))
; ペグ・ソリテア 12 穴盤の解法
(defun solve-peg12 (pos)
(let ((board (make-list 12 :initial-element t)))
; ペグをひとつ取り除く
(setf (nth pos board) nil
*count* 0)
(dotimes (x 10)
(format t "----- ~D 手 を探索 -------~%" (1+ x))
(solve-id 0 0 (1+ x) board nil)
(if (plusp *count*) (return)))))
戻る
;
; peg18.l : ペグ・ソリテア 18 穴盤の解法（反復深化＋下限値枝刈り法）
;
; Copyright (C) 2002 Makoto Hiroi
;
; 跳び先表 : (跳び越される位置 . 跳び越される位置)
(defvar *jump-table* #(((2 . 5) (3 . 7)) ; 0
((3 . 6) (4 . 8)) ; 1
((3 . 4) (5 . 9) (6 . 11)) ; 2
((6 . 10) (7 . 12)) ; 3
((3 . 2) (7 . 11) (8 . 13)) ; 4
((2 . 0) (6 . 7) (10 . 15)) ; 5
((3 . 1) (7 . 8) (10 . 14) (11 . 16)) ; 6
((3 . 0) (6 . 5) (11 . 15) (12 . 17)) ; 7
((4 . 1) (7 . 6) (12 . 16)) ; 8
((5 . 2) (10 . 11)) ; 9
((6 . 3) (11 . 12)) ; 10
((6 . 2) (7 . 4) (10 . 9) (12 . 13)) ; 11
((7 . 3) (11 . 10)) ; 12
((8 . 4) (12 . 11)) ; 13
((10 . 6) (15 . 16)) ; 14
((10 . 5) (11 . 7) (16 . 17)) ; 15
((11 . 6) (12 . 8) (15 . 14)) ; 16
((12 . 7) (16 . 15)))) ; 17
; 下限値の計算
(defun get-lower-value (board prev)
(let ((value 0))
; コーナーのチェック
(dolist (c '(0 1 9 13 14 17))
(if (and (nth c board) (not (eql c prev)))
(incf value)))
; 辺のチェック
(dolist (edge '((2 5) (4 8) (15 16)) value)
(unless (member prev edge)
(if (and (nth (first edge) board) (nth (second edge) board))
(incf value))))))
; ペグを動かす
(defun move-peg (n board pos)
(if board
(cons (if (member n pos)
(not (car board))
(car board))
(move-peg (1+ n) (cdr board) pos))))
; ペグの跳び方を求める (from del to)
(defun get-move-pattern (board)
(let (result del to)
(dotimes (from 18 result)
(when (nth from board)
(dolist (pos (aref *jump-table* from))
(setq del (car pos)
to (cdr pos))
(if (and (nth del board) (not (nth to board)))
(push (list from del to) result)))))))
; 解を表示する
(defun print-answer (history)
(let ((prev (third (car history))))
; 初手を表示
(format t "[~D, ~D" (first (car history)) prev)
; 2 手目以降を表示
(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)))
; 反復深化（下限値枝刈り法）
(defun solve-id (n jc limit board history)
(when (<= (+ jc (get-lower-value board (third (car history)))) limit)
(if (= n 16)
(print-answer (reverse history))
(dolist (pattern (get-move-pattern board))
(solve-id (1+ n)
(if (eql (third (car history)) (first pattern))
jc
(1+ jc))
limit
(move-peg 0 board pattern)
(cons pattern history))))))
; ペグ・ソリテア 18 穴盤の解法
(defun solve-peg18 (pos)
(let ((board (make-list 18 :initial-element t)))
; ペグをひとつ取り除く
(setf (nth pos board) nil)
(catch 'find-answer
(do ((limit (get-lower-value board nil) (1+ limit)))
((> limit 16))
(format t "----- ~D 手 を探索 -------~%" limit)
(solve-id 0 0 limit board nil)))))
戻る
;
; peg18_1.l : ペグ・ソリテア 18 穴盤の解法（反復深化＋下限値枝刈り法）
; 盤面を整数値で表し、ペグの状態をビットのオン・オフで表す
;
; Copyright (C) 2002 Makoto Hiroi
;
; 跳び先表 : (跳び越される位置 . 跳び越される位置)
(defvar *jump-table1* #(((2 . 5) (3 . 7)) ; 0
((3 . 6) (4 . 8)) ; 1
((3 . 4) (5 . 9) (6 . 11)) ; 2
((6 . 10) (7 . 12)) ; 3
((3 . 2) (7 . 11) (8 . 13)) ; 4
((2 . 0) (6 . 7) (10 . 15)) ; 5
((3 . 1) (7 . 8) (10 . 14) (11 . 16)) ; 6
((3 . 0) (6 . 5) (11 . 15) (12 . 17)) ; 7
((4 . 1) (7 . 6) (12 . 16)) ; 8
((5 . 2) (10 . 11)) ; 9
((6 . 3) (11 . 12)) ; 10
((6 . 2) (7 . 4) (10 . 9) (12 . 13)) ; 11
((7 . 3) (11 . 10)) ; 12
((8 . 4) (12 . 11)) ; 13
((10 . 6) (15 . 16)) ; 14
((10 . 5) (11 . 7) (16 . 17)) ; 15
((11 . 6) (12 . 8) (15 . 14)) ; 16
((12 . 7) (16 . 15)))) ; 17
; 跳び先表にビット反転用データを付加する
; データ構造は (del to bit-pattern)
(defun make-jump-table ()
(setq *jump-table* (make-array 18))
(dotimes (from 18)
(dolist (pattern (aref *jump-table1* from))
(let ((del (car pattern))
(to (cdr pattern)))
(push (list del to (logior (ash 1 from) (ash 1 del) (ash 1 to)))
(aref *jump-table* from))))))
; ペグの跳び方を求める
; データ構造は (new-board from del to)
(defun get-move-pattern (board)
(let (result del to)
(dotimes (from 18 result)
(when (logbitp from board)
(dolist (pos (aref *jump-table* from))
(setq del (first pos)
to (second pos))
(if (and (logbitp del board) (not (logbitp to board)))
(push (list (logxor board (third pos)) from del to) result)))))))
; 下限値を求める
(defun get-lower-value (board prev)
(unless (integerp prev) (setq prev 18))
(let* ((corner #b100110001000000011)
(count (logcount (logand board corner))))
; コーナーのチェック
(if (logbitp prev corner)
(decf count))
; 辺のチェック
(dolist (edge '(#b100100 #b100010000 #b11000000000000000) count)
(unless (logbitp prev edge)
(if (= edge (logand edge board))
(incf count))))))
; 解を表示する
(defun print-answer (history)
(let ((prev (third (car history))))
; 初手を表示
(format t "[~D, ~D" (first (car history)) prev)
; 2 手目以降を表示
(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)))
; 反復深化
(defun solve-id (n jc limit board history)
(when (<= (+ jc (get-lower-value board (third (car history)))) limit)
(if (= n 16)
(print-answer (reverse history))
; pattern の構造は (new-board from del to)
(dolist (pattern (get-move-pattern board))
(solve-id (1+ n)
(if (eql (third (car history)) (second pattern))
jc
(1+ jc))
limit
(first pattern)
(cons (cdr pattern) history))))))
; ペグ・ソリテア 18 穴盤の解法
(defun solve-peg18 (pos)
(let ((board (logxor #x1ffffff (ash 1 pos))))
(make-jump-table)
(catch 'find-answer
(do ((limit (get-lower-value board nil) (1+ limit)))
((> limit 16))
(format t "----- ~D 手 を探索 -------~%" limit)
(solve-id 0 0 limit board nil)))))
戻る