前回は幅優先探索の例題として 8 パズルを解いてみました。今回は反復深化の例題として、ペグ・ソリテアと 8 パズルを解いてみましょう。
拙作のページ「経路の探索」で説明したように、反復深化は最短手数を求めることができるアルゴリズムです。幅優先探索と違って局面を保存する必要が無いため、必要となるメモリは深さ優先探索と同程度で済みます。また、プログラムも深さ優先探索と同じくらい簡単に作成することができます。
ただし、同じ探索を何度も繰り返すため実行時間が増大する、という欠点があります。ようするに、使用するメモリは少ないが実行時間が長くなるアルゴリズムなのです。実行時間が長くなるといっても、枝刈りを工夫することでパズルを高速に解くことができます。メモリ不足になる場合には、積極的に使ってみたいアルゴリズムといえるでしょう。
ペグ・ソリテアは盤上に配置されたペグ（駒）を、最後にはひとつ残るように取り除いていく古典的なパズルです。ペグは、次のルールに従って移動し、除去することができます。
盤は今までに多数考案されていますが、33 穴英国盤、37 穴フランス盤、41 穴盤が有名です。下図に 33 穴英国盤を示します。
●─●─●
│ │ │
●─●─●
│ │ │
●─●─●─●─●─●─●
│ │ │ │ │ │ │
●─●─●─○─●─●─●
│ │ │ │ │ │ │
●─●─●─●─●─●─●
│ │ │
●─●─●
│ │ │
●─●─●
図 : 33 穴英国盤
33 の穴にペグがありますが、そこからひとつペグを取り除いてゲームを始めます。図では黒丸でペグを表し、白丸で空き場所を表しています。ルールに従ってペグを移動し、最後にひとつだけ残ればクリアとなります。ただし、最初に取り除くペグの位置によって、解けない場合もあるので注意してください。
橋本哲氏の記事 (参考文献 3 『特集コンピュータパズルへの招待 ペグ・ソリテア編』) によると、最初の空き位置と最後に残ったペグの位置が同じになることを「補償型の解」といい、最初の空き位置が盤の中央で、なおかつ、補償型の解がある場合を「中央補償型の解」と呼ぶそうです。33 穴英国盤には、中央補償型の解があるそうです。
ペグ・ソリテアの場合、昔から補償型や中央補償型の解の最小手数を求めることが行われてきました。33 穴英国盤のように、ペグの数が多くなるとパソコンで解くのは大変になります。そこで、今回はサイズを小さくした簡単なペグ・ソリテアを反復深化で解いてみましょう。
Hoppers は芦ヶ原伸之氏が考案されたペグ・ソリテアです。次の図を見てください。
●───●───● │＼ ／│＼ ／│ │ ● │ ● │ │／ ＼│／ ＼│ ●───○───● │＼ ／│＼ ／│ │ ● │ ● │ │／ ＼│／ ＼│ ●───●───● 図 : Hoppers
Hoppers は穴を 13 個に減らしていて、遊ぶのに手頃な大きさになっています。上図に示したように、最初に中央のペグを取り除きます。この状態から始めて、最後のペグが中央の位置に残る跳び方の最小手数を求めることにします。
それでは、プログラムを作りましょう。今回は Hoppers の盤面をベクタではなく、整数値のビットを使って表すことにします。つまり、ペグがある状態をビットオン (1) で、ペグがない状態をビットオフ (0) で表します。盤面とビットの対応は、下図を見てください。
●───●───● ０───１───２
│＼ ／│＼ ／│ │＼ ／│＼ ／│
│ ● │ ● │ │ ３ │ ４ │
│／ ＼│／ ＼│ │／ ＼│／ ＼│
●───○───● ５───６───７
│＼ ／│＼ ／│ │＼ ／│＼ ／│
│ ● │ ● │ │ ８ │ ９ │
│／ ＼│／ ＼│ │／ ＼│／ ＼│
●───●───● 10───11───12
(1) Hoppers (2) ビットの位置
図 : Hoppers の盤面
ペグの移動は跳び先表を用意すると簡単です。次のプログラムを見てください。
リスト : 跳び先表
(defconstant jump-table
#(((1 2) (3 6) (5 10))
((3 5) (6 11) (4 7))
((1 0) (4 6) (7 12))
((6 9))
((6 8))
((3 1) (6 7) (8 11))
((3 0) (4 2) (8 10) (9 12))
((4 1) (6 5) (9 11))
((6 4))
((6 3))
((5 0) (8 6) (11 12))
((8 5) (6 1) (9 7))
((11 10) (9 6) (7 2))))
ペグの跳び先表はベクタ jump-table で定義します。ベクタの要素はリストであることに注意してください。リストの要素は、跳び越されるペグの位置と跳び先の位置を格納したリストです。たとえば、0 番の位置にあるペグは、1 番を跳び越して 2 番へ移動する場合と、3 番を跳び越して 6 番へ移動する場合と、5 番を飛び越して 10 番へ移動する場合の 3 通りがあります。これをリスト (1 2), (3 6), (5 10) で表しています。
次にペグを動かして新しい盤面を作る関数 move-peg を作ります。
リスト : ペグの移動 (defun move-peg (board from del to) (logxor board (ash 1 from) (ash 1 del) (ash 1 to)))
引数 from は跳ぶペグの位置、del は削除されるペグの位置、to は跳び先の位置を表します。from と del のビットをオフに、to のビットをオンにして、新しい盤面を生成します。from, to, del ともにビットを反転すればいいので、排他的論理和 logxor を使っています。
あとは単純な反復深化で最短手順を求めます。プログラムは次のようになります。
リスト : 反復深化による解法
;;; 移動できるか？
(defun movep (board del to)
(and (logbitp del board)
(not (logbitp to board))))
;;; 反復深化用深さ優先探索
(defun dfs (fn board goal jc limit move)
(when (<= jc limit)
(cond
((= (length move) max-jump)
(when (= board goal)
(funcall fn (reverse move))))
(t
(dotimes (from (length jump-table))
(when (logbitp from board)
(dolist (xs (aref jump-table from))
(when (movep board (first xs) (second xs))
(dfs fn
(move-peg board from (first xs) (second xs))
goal
(if (= from (cdar move))
jc
(1+ jc))
limit
(cons (cons from (second xs)) move))))))))))
;;; 反復深化
(defun solver-id (from del to)
(do ((c 0)
(i 2 (1+ i)))
((or (plusp c) (> i max-jump)) c)
(format t "----- ~d -----~%" i)
;; 初手を from -> to に限定
(dfs (lambda (xs) (print-answer xs) (incf c))
(logxor #x1fff (ash 1 from) (ash 1 del))
(ash 1 to)
1
i
(list (cons from to)))))
反復深化の処理は関数 dfs で行います。引数 FN は解を見つけたときに実行する関数、BOARD は盤面を表す整数、JC はペグが跳んだ回数、LIMIT は反復深化の上限値、MOVE は移動手順を格納するリストで、要素はドット対 (FORM . TO) です。
ペグ・ソリテアを反復深化で解く場合、上限値 LIMIT に達していても連続跳びによりペグを移動できることに注意してください。最初に、JC をチェックして LIMIT 以下であればペグを移動します。Hoppers の場合、ペグの総数は 12 個なので、MAX-JUMP (11) 回ペグを移動すると残りのペグは 1 個になります。解を見つけたら FN を評価します。
そうでなければペグを移動します。dotimes の変数 FROM が動かすペグの位置を表します。FROM の位置にペグがあることを logbitp で確認します。それから、跳び先表から跳び越されるペグの位置と跳び先の位置を取り出して変数 XS にセットします。(first xs) が跳び越されるペグの位置、(second xs) が跳び先の位置になります。跳び越されるペグがあり、跳び先が空いていれば、FROM のペグを移動することができます。これを関数 movep でチェックします。
ペグを動かすことができる場合は dfs を再帰呼び出しします。move-peg でペグを動かして新しい盤面を生成します。そして、このプログラムのポイントが連続跳びのチェックをするところです。直前に移動した場所からペグを動かすときは、連続跳びと判断することができます。MOVE の先頭要素の CDR 部 (cdar move) が FROM と等しい場合は、跳んだ回数 JC を増やしません。異なる場合は JC の値を +1 します。
あとは関数 solver-id で反復深化の上限値を増やしながら dfs を呼び出します。引数 FROM, DEL, TO で最初に跳ぶペグを指定します。中央のペグを取り除く場合、最初は四隅にあるペグのひとつを中央に動かす手順しかありません。そこで、最初は 0, 2, 10, 12 のペグのひとつを 6 へ動かすことに決めて、その状態から探索を開始します。dfs に渡すラムダ式では、手順を表示する関数 print-answer を呼び出して変数 C の値を +1 します。C が 0 でなければ、解を見つけたので反復深化を終了します。
なお、解をひとつ見つけるだけでよければ、dfs に渡すラムダ式で (return-from solver-id) を評価してください。
最後に手順を表示する関数 print-answer を作ります。
リスト : 手順の表示
(defun print-answer (move)
(let ((prev (cdar move)))
;; 初手を表示
(format t "[~D,~D" (caar move) prev)
;; 2 手目以降を表示する
(dolist (x (cdr move))
(cond ((= prev (car x))
;; 同じ駒が続けて跳ぶ
(setq prev (cdr x))
(format t ",~D" prev))
(t
(setq prev (cdr x))
(format t "]~%[~D,~D" (car x) prev))))
(format t "]~%~%")))
移動手順は 1 手を [from, to] で表し、連続跳びの場合は [from, to1, to2, ..., toN] とします。1 手前の跳び先の位置を変数 prev にセットしておいて、それと動かすペグの位置が同じであれば連続跳びです。跳び先の位置を prev にセットして、それを表示します。違うペグが跳ぶ場合は、] [ を表示してから動かすペグの位置と跳び先の位置を表示します。
これでプログラムは完成です。それでは実行してみましょう。
* (solver-id 0 3 6) ----- 2 ----- ----- 3 ----- ----- 4 ----- ----- 5 ----- ----- 6 ----- ----- 7 ----- [0,6] [9,3] [2,0,6] [11,1] [10,0,2,6] [8,4] [12,2,6] ・・・省略・・・ [0,6] [9,3] [10,6] [4,8] [12,10,6] [1,11] [2,12,10,0,6] 18
7 手で解くことができました。解は全部で 18 通りになりました。実行時間は 0.017 秒 (Ubunts 18.04 (Windows Subsystem for Linux), Intel Core i5-6200U 2.30GHz) でした。最近のパソコンは高性能なので、穴の数が少ない盤面であれば、単純な反復深化でも高速に解くことができるようです。
次は 8 パズルを反復深化で解いてみましょう。幅優先探索では全ての局面を保存しましたが、反復深化ではその必要はありません。前回と同様に盤面はベクタで表して、変数 board に格納します。駒の移動は board を書き換えて、バックトラックする時は元に戻すことにします。動かした駒はリスト move に格納します。動かした駒がわかれば盤面を再現できるので、それで移動手順を表すことにしましょう。
それでは、さっそくプログラムを作りましょう。次のリストを見てください。
リスト : 単純な反復深化による解法
;;; 反復深化用深さ優先探索
(defun dfs (fn board goal n limit space move)
(cond
((= n limit)
(when (equalp board goal)
(funcall fn (cdr (reverse move)))))
(t
(dolist (x (aref adjacent space))
(let ((p (aref board x)))
(unless (= p (car move))
;; 駒の移動
(setf (aref board space) p
(aref board x) 0)
(dfs fn board goal (1+ n) limit x (cons p move))
;; 元に戻す
(setf (aref board space) 0
(aref board x) p)))))))
;;; 反復深化
(defun solver-id (start goal)
(do ((c 0)
(i 1 (1+ i)))
((or (plusp c) (> i 31)) c)
(format t "----- ~d -----~%" i)
(dfs (lambda (xs) (format t "~a~%" xs) (incf c))
start
goal
0
i
(position 0 start)
'(-1))))
関数 dfs の引数 FN が解を見つけたときに評価する関数、BOARD が盤面、GOAL がゴールの盤面、N が手数、LIMIT が上限値、SPACE が空き場所の位置、MOVE が移動手順を格納したリストです。手数が上限値に達したら、パズルが解けたかチェックします。完成形に到達したら関数 FN を評価します。上限値に達していない場合は、駒を移動して新しい局面を作ります。
8 パズルのように、元の局面に戻すことが可能（可逆的）なパズルの場合、単純な深さ優先探索では同じ移動手順を何度も繰り返すことがあります。そうなると、とんでもない解を出力するだけではなく、再帰呼び出しが深くなるとスタックがオーバーフローしてプログラムの実行ができなくなることがあります。
このような場合、局面の履歴を保存しておいて同じ局面がないかチェックすることで、解を求めることができるようになります。ただし、同一局面をチェックする分だけ時間が余分にかかりますし、最初に見つかる解が最短手数とは限りません。
反復深化では深さが制限されているため、同一局面のチェックを行わなくてもスタックオーバーフローが発生することはありません。そのかわり、無駄な探索はどうしても避けることができません。8 パズルの場合、1 手前に動かした駒を再度動かすと 2 手前の局面に戻ってしまいます。完全ではありませんが、このチェックを入れるだけでもかなりの無駄を省くことができます。
プログラムでは、リスト MOVE に移動した駒を格納しているので、1 手前と同じ駒は動かさないようにチェックしています。なお、MOVE の最後尾の要素はダミーデータで -1 をセットします。解を表示するときは、reverse でリストを反転したあと、ダミーデータを取り除くことに注意してください。
あとは、関数 solver-id から dfs を呼び出すだけです。変数 I が上限値を表します。I を 1 手ずつ増やして dfs を呼び出します。解を見つけたらラムダ式の中で変数 C の値を +1 します。プログラムはこれで完成です。
それでは実行してみましょう。
* (time (solver-id #(8 6 7 2 5 4 3 0 1) #(1 2 3 4 5 6 7 8 0))) ----- 1 ----- ----- 2 ----- ・・・省略・・・ ----- 30 ----- ----- 31 ----- (5 6 8 2 3 5 1 4 7 8 6 3 5 1 4 7 8 6 3 5 1 4 7 8 6 3 2 1 4 7 8) (5 6 7 4 6 2 3 5 1 6 2 3 8 7 4 2 3 1 5 8 7 4 1 5 8 7 4 1 2 3 6) ・・・省略・・・ (1 4 5 2 3 1 4 5 7 6 2 3 8 2 3 8 1 4 8 7 5 8 7 5 6 3 2 1 4 7 8) (1 4 5 2 3 1 4 5 7 6 2 3 8 2 3 8 1 4 5 7 8 5 7 8 6 3 2 1 4 7 8) Evaluation took: 17.176 seconds of real time 17.140625 seconds of total run time (16.781250 user, 0.359375 system) [ Run times consist of 0.204 seconds GC time, and 16.937 seconds non-GC time. ] 99.80% CPU 41,221,616,369 processor cycles 3,857,219,520 bytes consed 40
当然ですが最短手数は 31 手で 40 通りの手順が表示されました。実行時間は 17.2 秒かかりました。反復深化の場合、枝刈りを工夫しないと高速に解くことはできません。そこで、反復深化の常套手段である「下限値枝刈り法」を使うことにしましょう。
下限値枝刈り法は難しいアルゴリズムではありません。たとえば、5 手進めた局面を考えてみます。探索の上限値が 10 手とすると、あと 5 手だけ動かすことができますね。この時、パズルを解くのに 6 手以上かかることがわかれば、ここで探索を打ち切ることができます。
このように、必要となる最低限の手数が明確にわかる場合、この値を「下限値 (Lower Bound)」と呼びます。この下限値を求めることができれば、「今の移動手数＋下限値」が探索手数を超えた時点で、枝刈りすることが可能になります。これが下限値枝刈り法の基本的な考え方です。
さて、下限値を求める方法ですが、これにはいろいろな方法が考えられます。今回は、各駒が正しい位置へ移動するまでの手数 (移動距離) [*1] を下限値として利用することにしましょう。次の図を見てください。
たとえば、右下にある 1 の駒を左上の正しい位置に移動するには、最低でも 4 手必要です。もちろん、ほかの駒との関連で、それ以上の手数が必要になる場合もあるでしょうが、4 手より少なくなることは絶対にありません。同じように、各駒について最低限必要な手数を求めることができます。そして、その合計値はパズルを解くのに最低限必要な手数となります。これを下限値として利用することができます。ちなみに、上図 (2) の初期状態の下限値は 21 手になります。
┌─┬─┬─┐ ┌──┬──┬──┐
│１│２│３│ │8(3)│6(2)│7(4)│
├─┼─┼─┤ ├──┼──┼──┤
│４│５│６│ │2(2)│5(0)│4(2)│
├─┼─┼─┤ ├──┼──┼──┤
│７│８│ │ │3(4)│ │1(4)│
└─┴─┴─┘ └──┴──┴──┘
(n) : n は移動距離
(1) 完成形 (2) 初期状態：合計 21
図 : 下限値の求め方
下限値枝刈り法を使う場合、下限値の計算を間違えると正しい解を求めることができなくなります。たとえば、10 手で解ける問題の下限値を 11 手と計算すれば、最短手数を求めることができなくなります。それどころか、10 手の解しかない場合は、答えを求めることすらできなくなります。下限値の計算には十分に注意してください。
それでは、プログラムを作りましょう。下限値の求め方ですが、駒を動かすたびに各駒の移動距離を計算していたのでは時間がかかります。8 パズルの場合、1 回に一つの駒しか移動しないので、初期状態の下限値を求めておいて、動かした駒の差分だけ計算すればいいでしょう。また、駒の移動距離はいちいち計算するのではなく、あらかじめ計算した結果を配列に格納しておきます。この配列を distance とすると、盤面から移動距離を求めるプログラムは次のようになります。
リスト : 移動距離を求める
;;; 移動距離 (マンハッタン距離)
(defconstant distance
#2A((0 0 0 0 0 0 0 0 0) ; dummy
(0 1 2 1 2 3 2 3 4)
(1 0 1 2 1 2 3 2 3)
(2 1 0 3 2 1 4 3 2)
(1 2 3 0 1 2 1 2 3)
(2 1 2 1 0 1 2 1 2)
(3 2 1 2 1 0 3 2 1)
(2 3 4 1 2 3 0 1 2)
(3 2 3 2 1 2 1 0 1)))
;;; 移動距離を求める
(defun calc-distance (board)
(let ((d 0))
(dotimes (i (length board) d)
(incf d (aref distance (aref board i) i)))))
DISTANCE は 2 次元配列で「駒の種類×駒の位置」を表しています。空き場所は関係ないので、0 行目の要素はすべて 0 となります。関数 calc-distance は盤面 board にある駒と位置から移動距離を求めます。変数 d を 0 に初期化して、駒の移動距離を distance で求めて d に足し算するだけです。
次は、下限値枝刈り法による反復深化を行うプログラムを作ります。次のリストを見てください。
リスト : 反復深化＋下限値枝刈り法
;;; 深さ優先探索
(defun dfs-lower (fn board goal n limit space move lower)
(cond
((= n limit)
(when (equalp board goal)
(funcall fn (cdr (reverse move)))))
(t
(dolist (x (aref adjacent space))
(let* ((p (aref board x))
(new-lower (+ (- lower (aref distance p x))
(aref distance p space))))
(when (and (/= p (car move))
(<= (+ new-lower n) limit))
;; 駒の移動
(setf (aref board space) p
(aref board x) 0)
(dfs-lower fn board goal (1+ n) limit x (cons p move) new-lower)
;; 元に戻す
(setf (aref board space) 0
(aref board x) p)))))))
;;; 反復深化＋下限値枝刈り法
(defun solver-id-lower (start goal)
(do* ((c 0)
(lower (calc-distance start))
(i lower (1+ i)))
((or (plusp c) (> i 31)) c)
(format t "----- ~d -----~%" i)
(dfs-lower
(lambda (xs) (format t "~a~%" xs) (incf c))
start
goal
0
i
(position 0 start)
'(-1)
lower)))
関数 dfs-lower の引数 LOWER は現在の盤面 BOARD の下限値を表しています。駒を動かしたら差分を計算して、新しい下限値 NEW-LOWER を求めます。そして、NEW-LOWER + N が上限値 LIMIT を越えたら枝刈りを行います。LIMIT 以下であれば dfs-lower を再帰呼び出しします。追加する処理はこれだけで、あとは反復深化のプログラムと同じです。とても簡単ですね。
最後に dfs-lower を呼び出す処理を修正します。関数 calc-distance で初期状態の下限値 LOWER を求めます。下限値がわかるのですから、上限値 LIMIT は 1 手からではなく下限値 LOWER からスタートします。あとは dfs-lower に下限値 LOWER を渡して呼び出すだけです。
プログラムの主な修正はこれだけです。それでは実行してみましょう。
* (time (solver-id-lower #(8 6 7 2 5 4 3 0 1) #(1 2 3 4 5 6 7 8 0))) ----- 21 ----- ----- 22 ----- ----- 23 ----- ----- 24 ----- ----- 25 ----- ----- 26 ----- ----- 27 ----- ----- 28 ----- ----- 29 ----- ----- 30 ----- ----- 31 ----- (5 6 8 2 3 5 1 4 7 8 6 3 5 1 4 7 8 6 3 5 1 4 7 8 6 3 2 1 4 7 8) (5 6 7 4 6 2 3 5 1 6 2 3 8 7 4 2 3 1 5 8 7 4 1 5 8 7 4 1 2 3 6) ・・・省略・・・ (1 4 5 2 3 1 4 5 7 6 2 3 8 2 3 8 1 4 8 7 5 8 7 5 6 3 2 1 4 7 8) (1 4 5 2 3 1 4 5 7 6 2 3 8 2 3 8 1 4 5 7 8 5 7 8 6 3 2 1 4 7 8) Evaluation took: 0.020 seconds of real time 0.015625 seconds of total run time (0.015625 user, 0.000000 system) 80.00% CPU 47,409,579 processor cycles 2,227,584 bytes consed 40
実行時間は 0.02 秒でした。約 860 倍という高速化に驚いてしまいました。下限値枝刈り法の効果は極めて高いですね。
下図のペグ・ソリティア「三角盤 (15 穴盤)」において、「補償型の解」の中で最小手数となるものを求めてください。
●
／ ＼
● ●
／ ＼ ／ ＼
●───●───●
／ ＼ ／ ＼ ／ ＼
●───●───●───●
／ ／ ＼ ／ ＼ ＼
●───●───●───●───●
図 : 三角盤
;;;
;;; hoppers.lisp : 反復深化による Hoppers の解法
;;;
;;; Copyright (C) 2020 Makoto Hiroi
;;;
;;; 跳び先表
(defconstant jump-table
#(((1 2) (3 6) (5 10))
((3 5) (6 11) (4 7))
((1 0) (4 6) (7 12))
((6 9))
((6 8))
((3 1) (6 7) (8 11))
((3 0) (4 2) (8 10) (9 12))
((4 1) (6 5) (9 11))
((6 4))
((6 3))
((5 0) (8 6) (11 12))
((8 5) (6 1) (9 7))
((11 10) (9 6) (7 2))))
;;; 最大のジャンプ回数
(defconstant max-jump 11)
;;; ペグの移動
(defun move-peg (board from del to)
(logxor board (ash 1 from) (ash 1 del) (ash 1 to)))
;;; 手順の表示
(defun print-answer (move)
(let ((prev (cdar move)))
;; 初手を表示
(format t "[~D,~D" (caar move) prev)
;; 2 手目以降を表示する
(dolist (x (cdr move))
(cond ((= prev (car x))
;; 同じ駒が続けて跳ぶ
(setq prev (cdr x))
(format t ",~D" prev))
(t
(setq prev (cdr x))
(format t "]~%[~D,~D" (car x) prev))))
(format t "]~%~%")))
;;; 移動できるか？
(defun movep (board del to)
(and (logbitp del board)
(not (logbitp to board))))
;;; 反復深化
(defun dfs (fn board goal jc limit move)
(when (<= jc limit)
(cond
((= (length move) max-jump)
(when (= board goal)
(funcall fn (reverse move))))
(t
(dotimes (from (length jump-table))
(when (logbitp from board)
(dolist (xs (aref jump-table from))
(when (movep board (first xs) (second xs))
(dfs fn
(move-peg board from (first xs) (second xs))
goal
(if (= from (cdar move))
jc
(1+ jc))
limit
(cons (cons from (second xs)) move))))))))))
(defun solver-id (from del to)
(do ((c 0)
(i 2 (1+ i)))
((or (plusp c) (> i max-jump)) c)
(format t "----- ~d -----~%" i)
;; 初手を from -> to に限定
(dfs (lambda (xs) (print-answer xs) (incf c))
(logxor #x1fff (ash 1 from) (ash 1 del))
(ash 1 to)
1
i
(list (cons from to)))))
;;;
;;; eight_id.lisp : 反復深化による８パズルの解法
;;;
;;; Copyright (C) 2020 Makoto Hiroi
;;;
;;; 盤面
;;; 0 1 2
;;; 3 4 5
;;; 6 7 8
;;; 隣接行列
(defconstant adjacent
#((1 3) ; 0
(0 2 4) ; 1
(1 5) ; 2
(0 4 6) ; 3
(1 3 5 7) ; 4
(2 4 8) ; 5
(3 7) ; 6
(4 6 8) ; 7
(5 7))) ; 8
;;; 反復深化用深さ優先探索
(defun dfs (fn board goal n limit space move)
(cond
((= n limit)
(when (equalp board goal)
(funcall fn (cdr (reverse move)))))
(t
(dolist (x (aref adjacent space))
(let ((p (aref board x)))
(unless (= p (car move))
;; 駒の移動
(setf (aref board space) p
(aref board x) 0)
(dfs fn board goal (1+ n) limit x (cons p move))
;; 元に戻す
(setf (aref board space) 0
(aref board x) p)))))))
;;; 反復深化
(defun solver-id (start goal)
(do ((c 0)
(i 1 (1+ i)))
((or (plusp c) (> i 31)) c)
(format t "----- ~d -----~%" i)
(dfs (lambda (xs) (format t "~a~%" xs) (incf c))
start
goal
0
i
(position 0 start)
'(-1))))
;;; 移動距離 (マンハッタン距離)
(defconstant distance
#2A((0 0 0 0 0 0 0 0 0) ; dummy
(0 1 2 1 2 3 2 3 4)
(1 0 1 2 1 2 3 2 3)
(2 1 0 3 2 1 4 3 2)
(1 2 3 0 1 2 1 2 3)
(2 1 2 1 0 1 2 1 2)
(3 2 1 2 1 0 3 2 1)
(2 3 4 1 2 3 0 1 2)
(3 2 3 2 1 2 1 0 1)))
;;; 移動距離を求める
(defun calc-distance (board)
(let ((d 0))
(dotimes (i (length board) d)
(incf d (aref distance (aref board i) i)))))
;;; 下限値枝刈り法
(defun dfs-lower (fn board goal n limit space move lower)
(cond
((= n limit)
(when (equalp board goal)
(funcall fn (cdr (reverse move)))))
(t
(dolist (x (aref adjacent space))
(let* ((p (aref board x))
(new-lower (+ (- lower (aref distance p x))
(aref distance p space))))
(when (and (/= p (car move))
(<= (+ new-lower n) limit))
;; 駒の移動
(setf (aref board space) p
(aref board x) 0)
(dfs-lower fn board goal (1+ n) limit x (cons p move) new-lower)
;; 元に戻す
(setf (aref board space) 0
(aref board x) p)))))))
;;; 反復深化＋下限値枝刈り法
(defun solver-id-lower (start goal)
(do* ((c 0)
(lower (calc-distance start))
(i lower (1+ i)))
((or (plusp c) (> i 31)) c)
(format t "----- ~d -----~%" i)
(dfs-lower
(lambda (xs) (format t "~a~%" xs) (incf c))
start
goal
0
i
(position 0 start)
'(-1)
lower)))
プログラムは hoppers.lisp を改造すると簡単に作成できます。
０
／ ＼
１ ２
／ ＼ ／ ＼
３───４───５
／ ＼ ／ ＼ ／ ＼
６───７───８───９
／ ／ ＼ ／ ＼ ＼
10───11───12───13───14
図 : 三角盤の番号
上図のように穴の位置を定義すると、三角盤の対称性により最初に取り除くペグは 0, 1, 3, 4 の 4 つになります。結果は次のようになりました。
* (solver-id 3 1 0) ----- 2 ----- ・・・省略・・・ ----- 10 ----- [3,0][5,3][0,5][6,1][9,2][11,4][13,11][10,12,5][2,9][14,5,3,0] NIL * (solver-id 6 3 1) ----- 2 ----- ・・・省略・・・ ----- 11 ----- [6,1][5,3][0,5][1,6][9,2][11,4][13,11][10,12,5][2,9][14,5,3][6,1] NIL * (solver-id 8 4 1) ----- 2 ----- ・・・省略・・・ ----- 13 ----- 0 * (solver-id 10 6 3) ----- 2 ----- ・・・省略・・・ ----- 9 ----- [10,3][1,6][5,3][0,5][6,1][9,2][13,4][11,13][14,12,3,0,5,3] NIL * (solver-id 12 7 3) ----- 2 ----- ・・・省略・・・ ----- 10 ----- [12,3][2,7][9,2][10,12,5][6,8][1,6][2,9,7][14,12,3][6,1][0,3] NIL * (solver-id 11 7 4) ----- 2 ----- ・・・省略・・・ ----- 13 ----- 0
最初に 3 を取り除く場合が最小で、手数は 9 手になりました。最初に 4 を取り除く場合、補償型の解は存在しませんが、最後のペグが 12 に残る解が存在します。興味のある方はいろいろ試してみてください。
;;;
;;; peg15.lisp : ペグ・ソリティア 15 穴盤
;;;
;;; Copyright (C) 2020 Makoto Hiroi
;;;
;;; 跳び先表
(defconstant jump-table
#(((1 3) (2 5)) ; 0
((3 6) (4 8)) ; 1
((4 7) (5 9)) ; 2
((1 0) (4 5) (6 10) (7 12)) ; 3
((7 11) (8 13)) ; 4
((2 0) (4 3) (8 12) (9 14)) ; 5
((3 1) (7 8)) ; 6
((4 2) (8 9)) ; 7
((4 1) (7 6)) ; 8
((5 2) (8 7)) ; 9
((6 3) (11 12)) ; 10
((7 4) (12 13)) ; 11
((7 3) (8 5) (11 10) (13 14)) ; 12
((8 4) (12 11)) ; 13
((9 5) (13 12)))) ; 14
;;; 最大のジャンプ回数
(defconstant max-jump 13)
;;; ペグの移動
(defun move-peg (board from del to)
(logxor board (ash 1 from) (ash 1 del) (ash 1 to)))
;;; 手順の表示
(defun print-answer (move)
(let ((prev (cdar move)))
;; 初手を表示
(format t "[~D,~D" (caar move) prev)
;; 2 手目以降を表示する
(dolist (x (cdr move))
(cond ((= prev (car x))
;; 同じ駒が続けて跳ぶ
(setq prev (cdr x))
(format t ",~D" prev))
(t
(setq prev (cdr x))
(format t "][~D,~D" (car x) prev))))
(format t "]~%")))
;;; 移動できるか？
(defun movep (board del to)
(and (logbitp del board)
(not (logbitp to board))))
;;; 反復深化
(defun dfs (fn board goal jc limit move)
(when (<= jc limit)
(cond
((= (length move) max-jump)
(when (= board goal)
(funcall fn (reverse move))))
(t
(dotimes (from (length jump-table))
(when (logbitp from board)
(dolist (xs (aref jump-table from))
(when (movep board (first xs) (second xs))
(dfs fn
(move-peg board from (first xs) (second xs))
goal
(if (= from (cdar move))
jc
(1+ jc))
limit
(cons (cons from (second xs)) move))))))))))
(defun solver-id (from del to)
(do ((c 0)
(i 2 (1+ i)))
((or (plusp c) (> i max-jump)) c)
(format t "----- ~d -----~%" i)
;; 初手を from -> to に限定
(dfs (lambda (xs) (print-answer xs) (incf c) (return-from solver-id))
(logxor #x7fff (ash 1 from) (ash 1 del))
(ash 1 to)
1
i
(list (cons from to)))))