前回は幅優先探索の例題として 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 の盤面
ペグの移動は跳び先表を用意すると簡単です。次のプログラムを見てください。
リスト : 跳び先表
(def 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 で定義します。ベクタの要素はベクタで、その要素はリストです。リストの第 1 要素が跳び越されるペグの位置、第 2 要素が跳び先の位置を表します。たとえば、0 番の位置にあるペグは、1 番を跳び越して 2 番へ移動する場合と、3 番を跳び越して 6 番へ移動する場合と、5 番を飛び越して 10 番へ移動する場合の 3 通りがあります。これをリスト (1 2), (3 6), (5 10) で表しています。
次にペグを動かして新しい盤面を作る関数 move-peg を作ります。
リスト : ペグの移動 (defn move-peg [board from del to] (-> board (bit-clear from) (bit-clear del) (bit-set to)))
引数 from は跳ぶペグの位置、del は削除されるペグの位置、to は跳び先の位置を表します。from と del のビットをオフに、to のビットをオンにして、新しい盤面を生成します。
-> はマクロで、次の S 式と同じ働きをします。
(-> item (form1 x1 y1 ...) (form2 x2 y2 ...) (form3 x3 y3 ...)) ≡(form3 (from2 (form1 item x1 y1 ...) x2 y2 ...) x3 y3 ...)
item または form の評価結果が、次の form の第 1 引数に渡されることに注意してください。-> は最後の form の評価結果を返します。-> は reduce の動作と似ています。簡単な例を示しましょう。
user=> (-> 0 (+ 1) (+ 2) (+ 3) (+ 4) (+ 5)) 15 user=> (-> 0 inc inc inc inc inc) 5
Clojure には評価結果を form の最後の引数に渡すマクロ ->> もあります。
あとは単純な反復深化で最短手順を求めます。プログラムは次のようになります。
リスト : 反復深化による解法
;; 移動できるか？
(defn move? [board del to]
(and (bit-test board del)
(not (bit-test board to))))
;; 反復深化用深さ優先探索
(defn dfs [proc board goal jc limit [[_ to0] & _ :as move]]
(when (<= jc limit)
(if (== (count move) max-jump)
(when (= board goal)
(proc (reverse move)))
(dotimes [from (count jump-table)]
(when (bit-test board from)
(doseq [[del to] (get jump-table from)]
(when (move? board del to)
(dfs proc
(move-peg board from del to)
goal
(if (== from to0) jc (inc jc))
limit
(cons (list from to) move)))))))))
;; 反復深化
(defn solver-id [from del to]
(let [c (atom 0)]
(loop [i 2]
(when (and (zero? @c) (<= i max-jump))
(printf "----- %d -----\n" i)
;; 初手を from -> to に限定
(dfs (fn [xs] (print-answer xs) (swap! c inc))
(-> 0x1fff (bit-clear from) (bit-clear del))
(bit-set 0 to)
1
i
(list (list from to)))
(recur (inc i))))
@c))
反復深化の処理は関数 dfs で行います。引数 proc は解を見つけたときに実行する関数、board は盤面を表す整数、jc はペグが跳んだ回数、limit は反復深化の上限値、move は移動手順を格納するリストで、要素はリスト (form to) です。
ペグ・ソリテアを反復深化で解く場合、上限値 limit に達していても連続跳びによりペグを移動できることに注意してください。最初に、jc をチェックして limit 以下であればペグを移動します。Hoppers の場合、ペグの総数は 12 個なので、max-jump (11) 回ペグを移動すると残りのペグは 1 個になります。解を見つけたら proc を評価します。
そうでなければペグを移動します。dotimes の変数 from が動かすペグの位置を表します。from の位置にペグがあることを bit-test で確認します。次に doseq で、跳び先表から跳び越されるペグの位置と跳び先の位置を取り出して変数 del と to にセットします。del が跳び越されるペグの位置、to が跳び先の位置になります。跳び越されるペグがあり、跳び先が空いていれば、from のペグを移動することができます。これを関数 move? でチェックします。
ペグを動かすことができる場合は dfs を再帰呼び出しします。move-peg でペグを動かして新しい盤面を生成します。そして、このプログラムのポイントが連続跳びのチェックをするところです。直前に移動した場所からペグを動かすときは、連続跳びと判断することができます。move の先頭要素を分配束縛 [_ to0] で分解します。to0 が from と等しい場合は、跳んだ回数 jc を増やしません。異なる場合は jc の値を +1 します。
あとは関数 solver-id で反復深化の上限値を増やしながら dfs を呼び出します。引数 from, del, to で最初に跳ぶペグを指定します。中央のペグを取り除く場合、最初は四隅にあるペグのひとつを中央に動かす手順しかありません。そこで、最初は 0, 2, 10, 12 のペグのひとつを 6 へ動かすことに決めて、その状態から探索を開始します。dfs に渡す無名関数では、手順を表示する関数 print-answer を呼び出して変数 c の値を +1 します。c が 0 でなければ、解を見つけたので反復深化を終了します。
最後に手順を表示する関数 print-answer を作ります。
リスト : 手順の表示
(defn print-answer [[[from0 to0] & xs]]
;; 初手を表示
(printf "[%d,%d" from0 to0)
;; 2 手目以降を表示する
(loop [[[from to] & ys :as zs] xs
prev to0]
(when (seq zs)
(if (== prev from)
;; 同じ駒が続けて跳ぶ
(printf ",%d" to)
(printf "]\n[%d,%d" from to))
(recur ys to)))
(printf "]\n\n"))
移動手順は 1 手を [from, to] で表し、連続跳びの場合は [from, to1, to2, ..., toN] とします。1 手前の跳び先の位置を変数 prev にセットしておいて、それと動かすペグの位置が同じであれば連続跳びです。それを表示します。違うペグが跳ぶ場合は、] [ を表示してから動かすペグの位置と跳び先の位置を表示します。loop / recur で繰り返すとき、to を loop の変数 prev にセットします。
これでプログラムは完成です。それでは実行してみましょう。
user=> (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.135 秒 (Ubunts 22.04 (WSL2), Intel Core i5-6200U 2.30GHz) でした。最近のパソコンは高性能なので、穴の数が少ない盤面であれば、単純な反復深化でも高速に解くことができるようです。
次は 8 パズルを反復深化で解いてみましょう。幅優先探索では全ての局面を保存しましたが、反復深化ではその必要はありません。前回と同様に盤面はベクタで表して、変数 board に格納します。Clojure のベクタは immutable なので、駒の移動で board を破壊的に書き換えることはできません。前回と同様に新しいベクタを生成することにします。動かした駒はリスト move に格納します。動かした駒がわかれば盤面を再現できるので、それで移動手順を表すことにしましょう。
それでは、さっそくプログラムを作りましょう。次のリストを見てください。
リスト : 単純な反復深化による解法
;; 反復深化用深さ優先探索
(defn dfs [proc board goal n limit space move]
(if (== n limit)
(when (= board goal)
(proc (rest (reverse move))))
(doseq [x (get adjacent space)]
(let [p (get board x)]
(when-not (== p (first move))
(dfs proc
(move-piece board x space)
goal
(inc n)
limit
x
(cons p move)))))))
;; 反復深化
(defn solver-id [start goal]
(let [c (atom 0)]
(loop [i 1]
(when (and (zero? @c) (<= i 31))
(printf "----- %d -----\n" i)
(dfs (fn [xs] (printf "%s\n" xs) (swap! c inc))
start
goal
0
i
(.indexOf start 0)
'(-1))
(recur (inc i))))
@c))
関数 dfs の引数 proc が解を見つけたときに評価する関数、board が盤面、goal がゴールの盤面、n が手数、limit が上限値、space が空き場所の位置、move が移動手順を格納したリストです。手数が上限値に達したら、パズルが解けたかチェックします。完成形に到達したら関数 proc を評価します。上限値に達していない場合は、駒を移動して新しい局面を作ります。
8 パズルのように、元の局面に戻すことが可能（可逆的）なパズルの場合、単純な深さ優先探索では同じ移動手順を何度も繰り返すことがあります。そうなると、とんでもない解を出力するだけではなく、再帰呼び出しが深くなるとスタックがオーバーフローしてプログラムの実行ができなくなることがあります。
このような場合、局面の履歴を保存しておいて同じ局面がないかチェックすることで、解を求めることができるようになります。ただし、同一局面をチェックする分だけ時間が余分にかかりますし、最初に見つかる解が最短手数とは限りません。
反復深化では深さが制限されているため、同一局面のチェックを行わなくてもスタックオーバーフローが発生することはありません。そのかわり、無駄な探索はどうしても避けることができません。8 パズルの場合、1 手前に動かした駒を再度動かすと 2 手前の局面に戻ってしまいます。完全ではありませんが、このチェックを入れるだけでもかなりの無駄を省くことができます。
プログラムでは、リスト move に移動した駒を格納しているので、1 手前と同じ駒は動かさないようにチェックしています。なお、move の最後尾の要素はダミーデータで -1 をセットします。解を表示するときは、reverse でリストを反転したあと、ダミーデータを取り除くことに注意してください。
あとは、関数 solver-id から dfs を呼び出すだけです。変数 i が上限値を表します。i を 1 手ずつ増やして dfs を呼び出します。解を見つけたら無名関数の中で変数 c の値を +1 します。プログラムはこれで完成です。
それでは実行してみましょう。
user=> (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 6Xo 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) "Elapsed time: 72926.734856 msecs" 40
当然ですが最短手数は 31 手で 40 通りの手順が表示されました。実行時間は 73 秒かかりました。反復深化の場合、枝刈りを工夫しないと高速に解くことはできません。そこで、反復深化の常套手段である「下限値枝刈り法」を使うことにしましょう。
下限値枝刈り法は難しいアルゴリズムではありません。たとえば、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 とすると、盤面から移動距離を求めるプログラムは次のようになります。
リスト : 移動距離を求める
;; 移動距離 (マンハッタン距離)
(def distance
[[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]])
(defn get-distance [p x]
(get (get distance p) x))
;; 移動距離を求める
(defn calc-distance [board]
(loop [i 0 d 0]
(if (>= i (count board))
d
(recur (inc i) (+ d (get-distance (get board i) i))))))
distance は 2 次元配列で「駒の種類×駒の位置」を表しています。空き場所は関係ないので、0 行目の要素はすべて 0 となります。関数 get-distance は distance から駒の移動距離を求めます。関数 calc-distance は盤面 board にある駒と位置から移動距離の合計値を求めます。変数 d を 0 に初期化して、駒の移動距離を get-distance で求めて d に足し算するだけです。
次は、下限値枝刈り法による反復深化を行うプログラムを作ります。次のリストを見てください。
リスト : 反復深化＋下限値枝刈り法
;; 下限値枝刈り法
(defn dfs-lower [proc board goal n limit space move lower]
(if (== n limit)
(when (= board goal)
(proc (rest (reverse move))))
(doseq [x (get adjacent space)]
(let [p (get board x)]
(when-not (== p (first move))
(let [new-lower (+ (- lower (get-distance p x))
(get-distance p space))]
(when (<= (+ new-lower n) limit)
(dfs-lower proc
(move-piece board x space)
goal
(inc n)
limit
x
(cons p move)
new-lower))))))))
;; 反復深化＋下限値枝刈り法
(defn solver-id-lower [start goal]
(let [c (atom 0)
lower (calc-distance start)]
(loop [i lower]
(when (and (zero? @c) (<= i 31))
(printf "----- %d -----\n" i)
(dfs-lower
(fn [xs] (printf "%s\n" xs) (swap! c inc))
start
goal
0
i
(.indexOf start 0)
'(-1)
lower)
(recur (inc i))))
@c))
関数 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) "Elapsed time: 225.66251 msecs" 40
実行時間は 0.225 秒でした。約 320 倍という高速化に驚いてしまいました。下限値枝刈り法の効果は極めて高いですね。
下図のペグ・ソリティア「三角盤 (15 穴盤)」において、「補償型の解」の中で最小手数となるものを求めてください。
●
／ ＼
● ●
／ ＼ ／ ＼
●───●───●
／ ＼ ／ ＼ ／ ＼
●───●───●───●
／ ／ ＼ ／ ＼ ＼
●───●───●───●───●
図 : 三角盤
;;;
;;; hoppers.clj: 反復深化による Hoppers の解法
;;;
;;; Copyright (C) 2025 Makoto Hiroi
;;;
;; 跳び先表
(def 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)]])
;; 最大のジャンプ回数
(def max-jump 11)
;; ペグの移動
(defn move-peg [board from del to]
(-> board (bit-clear from) (bit-clear del) (bit-set to)))
;; 手順の表示
(defn print-answer [[[from0 to0] & xs]]
;; 初手を表示
(printf "[%d,%d" from0 to0)
;; 2 手目以降を表示する
(loop [[[from to] & ys :as zs] xs
prev to0]
(when (seq zs)
(if (== prev from)
;; 同じ駒が続けて跳ぶ
(printf ",%d" to)
(printf "]\n[%d,%d" from to))
(recur ys to)))
(printf "]\n\n"))
;; 移動できるか？
(defn move? [board del to]
(and (bit-test board del)
(not (bit-test board to))))
;; 反復深化用深さ優先探索
(defn dfs [proc board goal jc limit [[_ to0] & _ :as move]]
(when (<= jc limit)
(if (== (count move) max-jump)
(when (= board goal)
(proc (reverse move)))
(dotimes [from (count jump-table)]
(when (bit-test board from)
(doseq [[del to] (get jump-table from)]
(when (move? board del to)
(dfs proc
(move-peg board from del to)
goal
(if (== from to0) jc (inc jc))
limit
(cons (list from to) move)))))))))
;; 反復深化
(defn solver-id [from del to]
(let [c (atom 0)]
(loop [i 2]
(when (and (zero? @c) (<= i max-jump))
(printf "----- %d -----\n" i)
;; 初手を from -> to に限定
(dfs (fn [xs] (print-answer xs) (swap! c inc))
(-> 0x1fff (bit-clear from) (bit-clear del))
(bit-set 0 to)
1
i
(list (list from to)))
(recur (inc i))))
@c))
;;;
;;; eight_id.clj : 反復深化による８パズルの解法
;;;
;;; Copyright (C) 2025 Makoto Hiroi
;;;
;; 盤面
;; 0 1 2
;; 3 4 5
;; 6 7 8
;; 隣接行列
(def 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
;; 駒の移動
(defn move-piece [board x space]
(assoc board space (get board x) x 0))
;; 反復深化用深さ優先探索
(defn dfs [proc board goal n limit space move]
(if (== n limit)
(when (= board goal)
(proc (rest (reverse move))))
(doseq [x (get adjacent space)]
(let [p (get board x)]
(when-not (== p (first move))
(dfs proc
(move-piece board x space)
goal
(inc n)
limit
x
(cons p move)))))))
;; 反復深化
(defn solver-id [start goal]
(let [c (atom 0)]
(loop [i 1]
(when (and (zero? @c) (<= i 31))
(printf "----- %d -----\n" i)
(dfs (fn [xs] (printf "%s\n" xs) (swap! c inc))
start
goal
0
i
(.indexOf start 0)
'(-1))
(recur (inc i))))
@c))
;; 移動距離 (マンハッタン距離)
(def distance
[[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]])
(defn get-distance [p x]
(get (get distance p) x))
;; 移動距離を求める
(defn calc-distance [board]
(loop [i 0 d 0]
(if (>= i (count board))
d
(recur (inc i) (+ d (get-distance (get board i) i))))))
;; 下限値枝刈り法
(defn dfs-lower [proc board goal n limit space move lower]
(if (== n limit)
(when (= board goal)
(proc (rest (reverse move))))
(doseq [x (get adjacent space)]
(let [p (get board x)]
(when-not (== p (first move))
(let [new-lower (+ (- lower (get-distance p x))
(get-distance p space))]
(when (<= (+ new-lower n) limit)
(dfs-lower proc
(move-piece board x space)
goal
(inc n)
limit
x
(cons p move)
new-lower))))))))
;; 反復深化＋下限値枝刈り法
(defn solver-id-lower [start goal]
(let [c (atom 0)
lower (calc-distance start)]
(loop [i lower]
(when (and (zero? @c) (<= i 31))
(printf "----- %d -----\n" i)
(dfs-lower
(fn [xs] (printf "%s\n" xs) (swap! c inc))
start
goal
0
i
(.indexOf start 0)
'(-1)
lower)
(recur (inc i))))
@c))
プログラムは hoppers.lisp を改造すると簡単に作成できます。
０
／ ＼
１ ２
／ ＼ ／ ＼
３───４───５
／ ＼ ／ ＼ ／ ＼
６───７───８───９
／ ／ ＼ ／ ＼ ＼
10───11───12───13───14
図 : 三角盤の番号
上図のように穴の位置を定義すると、三角盤の対称性により最初に取り除くペグは 0, 1, 3, 4 の 4 つになります。結果は次のようになりました。
user=> (solver-id 3 1 0) ----- 2 ----- ----- 3 ----- ----- 4 ----- ----- 5 ----- ----- 6 ----- ----- 7 ----- ----- 8 ----- ----- 9 ----- ----- 10 ----- [3,0] [5,3] [0,5] [6,1] [9,2] [11,4] [13,11] [10,12,5] [2,9] [14,5,3,0] 681 user=> (solver-id 6 3 1) ----- 2 ----- ----- 3 ----- ----- 4 ----- ----- 5 ----- ----- 6 ----- ----- 7 ----- ----- 8 ----- ----- 9 ----- ----- 10 ----- ----- 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] 252 user=> (solver-id 8 4 1) ----- 2 ----- ----- 3 ----- ----- 4 ----- ----- 5 ----- ----- 6 ----- ----- 7 ----- ----- 8 ----- ----- 9 ----- ----- 10 ----- ----- 11 ----- ----- 12 ----- ----- 13 ----- 0 user=> (solver-id 10 6 3) ----- 2 ----- ----- 3 ----- ----- 4 ----- ----- 5 ----- ----- 6 ----- ----- 7 ----- ----- 8 ----- ----- 9 ----- [10,3] [1,6] [5,3] [0,5] [6,1] [9,2] [13,4] [11,13] [14,12,3,0,5,3] 233 user=> (solver-id 12 7 3) ----- 2 ----- ----- 3 ----- ----- 4 ----- ----- 5 ----- ----- 6 ----- ----- 7 ----- ----- 8 ----- ----- 9 ----- ----- 10 ----- [12,3] [2,7] [9,2] [10,12,5] [6,8] [1,6] [2,9,7] [14,12,3] [6,1] [0,3] 496 user=> (solver-id 11 7 4) ----- 2 ----- ----- 3 ----- ----- 4 ----- ----- 5 ----- ----- 6 ----- ----- 7 ----- ----- 8 ----- ----- 9 ----- ----- 10 ----- ----- 11 ----- ----- 12 ----- ----- 13 ----- 0
最初に 3 を取り除く場合が最小で、手数は 9 手になりました。最初に 4 を取り除く場合、補償型の解は存在しませんが、最後のペグが 12 に残る解が存在します。興味のある方はいろいろ試してみてください。
;;;
;;; peg15.clj : ペグ・ソリティア 15 穴盤
;;;
;;; Copyright (C) 2025 Makoto Hiroi
;;;
;; 跳び先表
(def 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
;; 最大のジャンプ回数
(def max-jump 13)
;; ペグの移動
(defn move-peg [board from del to]
(-> board (bit-clear from) (bit-clear del) (bit-set to)))
;; 手順の表示
(defn print-answer [[[from0 to0] & xs]]
;; 初手を表示
(printf "[%d,%d" from0 to0)
;; 2 手目以降を表示する
(loop [[[from to] & ys :as zs] xs
prev to0]
(when (seq zs)
(if (== prev from)
;; 同じ駒が続けて跳ぶ
(printf ",%d" to)
(printf "]\n[%d,%d" from to))
(recur ys to)))
(printf "]\n\n"))
;; 移動できるか？
(defn move? [board del to]
(and (bit-test board del)
(not (bit-test board to))))
;; 反復深化
(defn dfs [proc board goal jc limit [[_ to0] & _ :as move]]
(when (<= jc limit)
(if (== (count move) max-jump)
(when (= board goal)
(proc (reverse move)))
(dotimes [from (count jump-table)]
(when (bit-test board from)
(doseq [[del to] (get jump-table from)]
(when (move? board del to)
(dfs proc
(move-peg board from del to)
goal
(if (== from to0) jc (inc jc))
limit
(cons (list from to) move)))))))))
(defn solver-id [from del to]
(let [c (atom 0)]
(loop [i 2]
(when (and (zero? @c) (<= i max-jump))
(printf "----- %d -----\n" i)
;; 初手を from -> to に限定
(dfs (fn [xs] (when (zero? @c) (print-answer xs)) (swap! c inc))
(-> 0x7fff (bit-clear from) (bit-clear del))
(bit-set 0 to)
1
i
(list (list from to)))
(recur (inc i))))
@c))