前回は幅優先探索の例題として 8 パズルを解いてみました。今回は反復深化の例題として、ペグ・ソリテアと 8 パズルを解いてみましょう。
拙作のページ「経路の探索」で説明したように、反復深化は最短手数を求めることができるアルゴリズムです。幅優先探索と違って局面を保存する必要が無いため、必要となるメモリは深さ優先探索と同程度で済みます。また、プログラムも深さ優先探索と同じくらい簡単に作成することができます。
ただし、同じ探索を何度も繰り返すため実行時間が増大する、という欠点があります。ようするに、使用するメモリは少ないが実行時間が長くなるアルゴリズムなのです。実行時間が長くなるといっても、枝刈りを工夫することでパズルを高速に解くことができます。メモリ不足になる場合には、積極的に使ってみたいアルゴリズムといえるでしょう。
ペグ・ソリテアは盤上に配置されたペグ（駒）を、最後にはひとつ残るように取り除いていく古典的なパズルです。ペグは、次のルールに従って移動し、除去することができます。
盤は今までに多数考案されていますが、33 穴英国盤、37 穴フランス盤、41 穴盤が有名です。下図に 33 穴英国盤を示します。
●─●─●
│ │ │
●─●─●
│ │ │
●─●─●─●─●─●─●
│ │ │ │ │ │ │
●─●─●─○─●─●─●
│ │ │ │ │ │ │
●─●─●─●─●─●─●
│ │ │
●─●─●
│ │ │
●─●─●
図 : 33 穴英国盤
33 の穴にペグがありますが、そこからひとつペグを取り除いてゲームを始めます。図では黒丸でペグを表し、白丸で空き場所を表しています。ルールに従ってペグを移動し、最後にひとつだけ残ればクリアとなります。ただし、最初に取り除くペグの位置によって、解けない場合もあるので注意してください。
橋本哲氏の記事『特集コンピュータパズルへの招待 ペグ・ソリテア編』によると、最初の空き位置と最後に残ったペグの位置が同じになることを「補償型の解」といい、最初の空き位置が盤の中央で、なおかつ、補償型の解がある場合を「中央補償型の解」と呼ぶそうです。33 穴英国盤には、中央補償型の解があるそうです。
ペグ・ソリテアの場合、昔から補償型や中央補償型の解の最小手数を求めることが行われてきました。33 穴英国盤のように、ペグの数が多くなるとパソコンで解くのは大変になります。そこで、今回はサイズを小さくした簡単なペグ・ソリテアを反復深化で解いてみましょう。
Hoppers は芦ヶ原伸之氏が考案されたペグ・ソリテアです。次の図を見てください。
●───●───● │＼ ／│＼ ／│ │ ● │ ● │ │／ ＼│／ ＼│ ●───○───● │＼ ／│＼ ／│ │ ● │ ● │ │／ ＼│／ ＼│ ●───●───● 図 : Hoppers
Hoppers は穴を 13 個に減らしていて、遊ぶのに手頃な大きさになっています。上図に示したように、最初に中央のペグを取り除きます。この状態から始めて、最後のペグが中央の位置に残る跳び方の最小手数を求めることにします。
それでは、プログラムを作りましょう。今回は Hoppers の盤面をベクタで表すことにします。ベクタの要素は真偽値です。ペグがある状態を #t で、ペグがない状態を #f で表します。ベクタの添字と盤面の対応は、下図を見てください。
●───●───● ０───１───２
│＼ ／│＼ ／│ │＼ ／│＼ ／│
│ ● │ ● │ │ ３ │ ４ │
│／ ＼│／ ＼│ │／ ＼│／ ＼│
●───○───● ５───６───７
│＼ ／│＼ ／│ │＼ ／│＼ ／│
│ ● │ ● │ │ ８ │ ９ │
│／ ＼│／ ＼│ │／ ＼│／ ＼│
●───●───● 10───11───12
(1) Hoppers (2) ビットの位置
図 : Hoppers の盤面
ペグの移動は跳び先表を用意すると簡単です。次のプログラムを見てください。
リスト : 跳び先表
(define *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) で表しています。
次に盤面とペグを操作する関数を定義します。
リスト : 盤面と操作関数の定義 ;;; 定数 (define HOLE 6) (define MAX-JUMP 11) (define SIZE 13) ;;; 大域変数 (define board (make-vector SIZE #t)) ; 盤面 (define found 0) ; 解の個数 ;;; ペグの移動 (define (move-peg from del to) (vector-set! board from #f) (vector-set! board del #f) (vector-set! board to #t)) (define (restore-peg from del to) (vector-set! board from #t) (vector-set! board del #t) (vector-set! board to #f))
盤面は大域変数 board に格納します。駒の移動は board を書き換えて、バックトラックする時は元に戻すことにします。関数 move-peg はペグを from から del を跳び越して to へ移動します。restore-peg は移動したペグを元に戻す関数です。
あとは単純な反復深化で最短手順を求めます。プログラムは次のようになります。
リスト : 反復深化による解法
(define (solver)
;; 深さ優先探索
(define (dfs jc limit move)
(when
(<= jc limit)
(cond
((= (length move) MAX-JUMP)
(when
(vector-ref board HOLE)
(print-answer (reverse move))
(set! found (+ found 1))))
(else
(do ((from 0 (+ from 1)))
((>= from SIZE))
(when
(vector-ref board from)
(for-each
(lambda (pos)
(let ((del (car pos)) (to (cadr pos)))
(when
(and (vector-ref board del)
(not (vector-ref board to)))
(move-peg from del to)
(dfs (if (= from (cdar move)) jc (+ jc 1))
limit
(cons (cons from (cadr pos)) move))
(restore-peg from del to))))
(vector-ref *jump-table* from))))))))
;; 初手を 0 -> 6 に限定
(move-peg 0 3 6)
(set! found 0)
(let loop ((i 2))
(cond
((<= i MAX-JUMP)
(display "----- ") (display i) (display " -----\n")
(dfs 1 i '((0 . 6)))
(when (zero? found)
(loop (+ i 1)))))))
反復深化の処理は局所関数 dfs で行います。引数 jc がペグが跳んだ回数、limit が反復深化の上限値、move が移動手順を格納するリストで、要素はドット対 (form . to) です。
ペグ・ソリテアを反復深化で解く場合、上限値 limit に達していても連続跳びによりペグを移動できることに注意してください。最初に、jc をチェックして limit 以下であればペグを移動します。Hoppers の場合、ペグの総数は 12 個なので、MAX-JUMP (11) 回ペグを移動すると残りのペグは 1 個になります。解を見つけたら print-answer で手順を表示して、見つけた解の個数 found を +1 します。
そうでなければペグを移動します。do の変数 from が動かすペグの位置を表します。まず from の位置にペグがあることを vector-ref で確認します。それから、跳び先表から跳び越されるペグの位置と跳び先の位置を for-each で順番に取り出します。これはラムダ式の引数 pos に渡されます。跳び越されるペグの位置 (car pos) を変数 del に、跳び先の位置 (cadr pos) を変数 to にセットします。del の位置にペグがあり to の位置にペグがなければ、from のペグを to へ移動することができます。
ペグを動かすことができる場合は dfs を再帰呼び出しします。move-peg でペグを動かします。そして、このプログラムのポイントが連続跳びのチェックをするところです。直前に移動した場所からペグを動かすときは、連続跳びと判断することができます。つまり、move の先頭要素の CDR 部 (cdar move) が from と等しい場合は、跳んだ回数 jc を増やしません。異なる場合は jc の値を +1 します。
あとは反復深化の上限値を増やしながら dfs を呼び出します。loop の変数 i が上限値を表します。最初の移動は、四隅にあるペグのひとつを中央に動かす手順しかありません。そこで、最初は 0 のペグを 6 へ動かすことに決めて、その状態から探索を開始します。found が 0 でなければ、解を見つけたので反復深化を終了します。
最後に手順を表示する関数 print-answer を作ります。
リスト : 手順の表示
(define (print-answer move)
(let ((prev (cdar move)))
;; 初手を表示
(display "[") (display (caar move)) (display ",") (display prev)
;; 2 手目以降を表示する
(for-each
(lambda (x)
(cond
((= prev (car x))
(set! prev (cdr x))
;; 同じ駒が続けて跳ぶ
(display ",") (display prev))
(else
(set! prev (cdr x))
(display "][") (display (car x))
(display ",") (display prev))))
(cdr move))
(display "]\n")))
移動手順は 1 手を [from, to] で表し、連続跳びの場合は [from, to1, to2, ..., toN] とします。1 手前の跳び先の位置を変数 prev にセットしておいて、それと動かすペグの位置が同じであれば連続跳びです。跳び先の位置を prev にセットして、それを表示します。違うペグが跳ぶ場合は、] [ を表示してから動かすペグの位置と跳び先の位置を表示します。
あとのプログラムは簡単なので説明は割愛します。詳細はプログラムリスト１をお読みください。
これでプログラムは完成です。それでは実行してみましょう。
$ gosh hoppers.scm ----- 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][2,0,6][11,1][10,6][4,8][12,2,0,10,6] [0,6][9,3][2,0,6][11,1][12,2,6][8,4][10,0,2,6] [0,6][9,3][2,6][8,4][10,0,2,6][7,5][12,10,0,6] [0,6][9,3][2,6][8,4][10,0,2,6][11,1][12,2,0,6] [0,6][9,3][2,6][8,4][10,0,6][7,5][12,10,0,2,6] [0,6][9,3][2,6][8,4][12,2,0,6][5,7][10,12,2,6] [0,6][9,3][2,6][8,4][12,2,0,6][11,1][10,0,2,6] [0,6][9,3][2,6][8,4][12,2,6][5,7][10,12,2,0,6] [0,6][9,3][10,0,6][7,5][2,0,10,6][4,8][12,10,6] [0,6][9,3][10,0,6][7,5][2,6][8,4][12,10,0,2,6] [0,6][9,3][10,0,6][7,5][12,10,6][4,8][2,0,10,6] [0,6][9,3][10,6][4,8][2,0,6][11,1][12,2,0,10,6] [0,6][9,3][10,6][4,8][2,0,10,6][7,5][12,10,0,6] [0,6][9,3][10,6][4,8][2,0,10,6][11,1][12,2,0,6] [0,6][9,3][10,6][4,8][12,10,0,6][1,11][2,12,10,6] [0,6][9,3][10,6][4,8][12,10,0,6][7,5][2,0,10,6] [0,6][9,3][10,6][4,8][12,10,6][1,11][2,12,10,0,6]
7 手で解くことができました。解は全部で 18 通りになりました。最近のパソコンは高性能なので、穴の数が少ない盤面であれば、単純な反復深化でも高速に解くことができるようです。
;;;
;;; hoppers.scm : ホッパーズ (ペグ・ソリテア)
;;;
;;; Copyright (C) 2008-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write))
;;; 跳び先表
(define *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))))
;;; 定数
(define HOLE 6)
(define MAX-JUMP 11)
(define SIZE 13)
;;; 大域変数
(define board (make-vector SIZE #t)) ; 盤面
(define found 0) ; 解の個数
;;; ペグの移動
(define (move-peg from del to)
(vector-set! board from #f)
(vector-set! board del #f)
(vector-set! board to #t))
(define (restore-peg from del to)
(vector-set! board from #t)
(vector-set! board del #t)
(vector-set! board to #f))
;;; 手順の表示
(define (print-answer move)
(let ((prev (cdar move)))
;; 初手を表示
(display "[") (display (caar move)) (display ",") (display prev)
;; 2 手目以降を表示する
(for-each
(lambda (x)
(cond
((= prev (car x))
(set! prev (cdr x))
;; 同じ駒が続けて跳ぶ
(display ",") (display prev))
(else
(set! prev (cdr x))
(display "][") (display (car x))
(display ",") (display prev))))
(cdr move))
(display "]\n")))
;;; 反復深化による解法
(define (solver)
;; 深さ優先探索
(define (dfs jc limit move)
(when
(<= jc limit)
(cond
((= (length move) MAX-JUMP)
(when
(vector-ref board HOLE)
(print-answer (reverse move))
(set! found (+ found 1))))
(else
(do ((from 0 (+ from 1)))
((>= from SIZE))
(when
(vector-ref board from)
(for-each
(lambda (pos)
(let ((del (car pos)) (to (cadr pos)))
(when
(and (vector-ref board del)
(not (vector-ref board to)))
(move-peg from del to)
(dfs (if (= from (cdar move)) jc (+ jc 1))
limit
(cons (cons from (cadr pos)) move))
(restore-peg from del to))))
(vector-ref *jump-table* from))))))))
;; 初手を 0 -> 6 に限定
(move-peg 0 3 6)
(set! found 0)
(let loop ((i 2))
(cond
((<= i MAX-JUMP)
(display "----- ") (display i) (display " -----\n")
(dfs 1 i '((0 . 6)))
(when (zero? found)
(loop (+ i 1)))))))
;;; 実行
(solver)
次は 8 パズルを反復深化で解いてみましょう。幅優先探索では全ての局面を保存しましたが、反復深化ではその必要はありません。前回と同様に盤面はベクタで表して、変数 board に格納します。駒の移動は board を書き換えて、バックトラックする時は元に戻すことにします。動かした駒はリスト move に格納します。動かした駒がわかれば盤面を再現できるので、それで移動手順を表すことにしましょう。
それでは、さっそくプログラムを作りましょう。次のリストを見てください。
リスト : 単純な反復深化による解法
(define (solver board goal)
;; フラグ
(define found 0)
;; 反復深化
(define (dfs n limit space move)
(cond
((= n limit)
(when
(equal? board goal)
(set! found (+ found 1))
(display (cdr (reverse move)))
(newline)))
(else
(for-each
(lambda (x)
(let ((p (vector-ref board x)))
(unless
(= (car move) p)
;; 駒の移動
(vector-set! board space p)
(vector-set! board x 0)
(dfs (+ n 1) limit x (cons p move))
;; 元に戻す
(vector-set! board x p)
(vector-set! board space 0))))
(vector-ref *adjacent* space)))))
;
(let loop ((i 1))
(when
(<= i 31)
(display "-----") (display i) (display "-----\n")
(dfs 0 i (vector-position zero? board) '(-1))
(when
(zero? found)
(loop (+ i 1))))))
局所関数 dfs の引数 n が手数、limit が上限値、space が空き場所の位置、move が移動手順を格納したリストです。手数が上限値に達したら、パズルが解けたかチェックします。goal は完成形を表すベクタです。完成形に到達したら、display で手順を表示します。上限値に達していない場合は、駒を移動して新しい局面を作ります。
8 パズルのように、元の局面に戻すことが可能 (可逆的) なパズルの場合、単純な深さ優先探索では同じ移動手順を何度も繰り返すことがあります。そうなると、とんでもない解を出力するだけではなく、再帰呼び出しが深くなるとスタックがオーバーフローしてプログラムの実行ができなくなることがあります。
このような場合、局面の履歴を保存しておいて同じ局面がないかチェックすることで、解を求めることができるようになります。ただし、同一局面をチェックする分だけ時間が余分にかかりますし、最初に見つかる解が最短手数とは限りません。
反復深化では深さが制限されているため、同一局面のチェックを行わなくてもスタックオーバーフローが発生することはありません。そのかわり、無駄な探索はどうしても避けることができません。8 パズルの場合、1 手前に動かした駒を再度動かすと 2 手前の局面に戻ってしまいます。完全ではありませんが、このチェックを入れるだけでもかなりの無駄を省くことができます。
プログラムでは、リスト move に移動した駒を格納しているので、1 手前と同じ駒は動かさないようにチェックしています。なお、move の最後尾の要素はダミーデータで -1 をセットします。解を表示するときは、reverse でリストを反転したあと、ダミーデータを取り除くことに注意してください。
あとは、関数 solver から内部関数 dfs を呼び出すだけです。変数 i が上限値を表します。i を 1 手ずつ増やして dfs を呼び出します。変数 found が 0 でなければ、解が見つかったのでループを脱出します。プログラムはこれで完成です。
実際に実行してみると、当然ですが最短手数は 31 手で 40 通りの手順が表示されました。実行時間は 2 分 58 秒 (Gauche version 0.9.9, Ubunts 18.04, Windows Subsystem for Linux, Intel Core i5-6200U 2.30GHz) かかりました。3 分近くかかるのですから、やっぱり遅いですね。反復深化の場合、枝刈りを工夫しないと高速に解くことはできません。そこで、反復深化の常套手段である「下限値枝刈り法」を使うことにしましょう。
下限値枝刈り法は難しいアルゴリズムではありません。たとえば、5 手進めた局面を考えてみます。探索の上限値が 10 手とすると、あと 5 手だけ動かすことができますね。この時、パズルを解くのに 6 手以上かかることがわかれば、ここで探索を打ち切ることができます。
このように、必要となる最低限の手数が明確にわかる場合、この値を「下限値 (Lower Bound)」と呼びます。この下限値を求めることができれば、「今の移動手数＋下限値」が探索手数を超えた時点で、枝刈りすることが可能になります。これが下限値枝刈り法の基本的な考え方です。
さて、下限値を求める方法ですが、これにはいろいろな方法が考えられます。今回は、各駒が正しい位置へ移動するまでの手数 (移動距離) [*1] を下限値として利用することにしましょう。次の図を見てください。
┌─┬─┬─┐ ┌──┬──┬──┐
│１│２│３│ │8(3)│6(2)│7(4)│
├─┼─┼─┤ ├──┼──┼──┤
│４│５│６│ │2(2)│5(0)│4(2)│
├─┼─┼─┤ ├──┼──┼──┤
│７│８│ │ │3(4)│ │1(4)│
└─┴─┴─┘ └──┴──┴──┘
(n) : n は移動距離
(1) 完成形 (2) 初期状態：合計 21
図 : 下限値の求め方
たとえば、右下にある 1 の駒を左上の正しい位置に移動するには、最低でも 4 手必要です。もちろん、ほかの駒との関連で、それ以上の手数が必要になる場合もあるでしょうが、4 手より少なくなることは絶対にありません。同じように、各駒について最低限必要な手数を求めることができます。そして、その合計値はパズルを解くのに最低限必要な手数となります。これを下限値として利用することができます。ちなみに、上図 (2) の初期状態の下限値は 21 手になります。
下限値枝刈り法を使う場合、下限値の計算を間違えると正しい解を求めることができなくなります。たとえば、10 手で解ける問題の下限値を 11 手と計算すれば、最短手数を求めることができなくなります。それどころか、10 手の解しかない場合は、答えを求めることすらできなくなります。下限値の計算には十分に注意してください。
それでは、プログラムを作りましょう。下限値の求め方ですが、駒を動かすたびに各駒の移動距離を計算していたのでは時間がかかります。8 パズルの場合、1 回に一つの駒しか移動しないので、初期状態の下限値を求めておいて、動かした駒の差分だけ計算すればいいでしょう。また、駒の移動距離はいちいち計算するのではなく、あらかじめ計算した結果をベクタに格納しておきます。このベクタを *distance* とすると、盤面から移動距離を求めるプログラムは次のようになります。
リスト : 移動距離を求める
;;; 移動距離
(define *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)))
;;; アクセス関数
(define (get-distance piece pos)
(vector-ref (vector-ref *distance* piece) pos))
;;; 移動距離を求める
(define (calc-distance board)
(let loop ((i 0) (d 0))
(if (<= (vector-length board) i)
d
(let ((p (vector-ref board i)))
(loop
(+ i 1)
(+ d (get-distance p i)))))))
*distance* は 2 次元配列で「駒の種類×駒の位置」を表しています。Scheme の場合、2 次元配列はベクタのベクタで表します。簡単にアクセスできるように関数 get-distance を用意します。空き場所は関係ないので、0 番目のベクタは全部の要素が 0 となります。
関数 calc-distance は盤面 board にある駒と位置から移動距離を求めます。変数 d を 0 に初期化して、駒の移動距離を get-distance で求めて d に足し算するだけです。
次は、下限値枝刈り法による反復深化を行う関数 solver2 を作ります。次のリストを見てください。
リスト : 下限値枝刈り法
(define (solver2 board goal)
;; フラグ
(define found 0)
;; 反復深化
(define (dfs n limit space move lower)
(cond
((= n limit)
(when
(equal? board goal)
(set! found (+ found 1))
(display (cdr (reverse move)))
(newline)))
(else
(for-each
(lambda (x)
(let ((p (vector-ref board x)))
(unless
(= (car move) p)
;; 下限値枝刈り法
(let ((new-lower (+ (- lower (get-distance p x)) (get-distance p space))))
(when
(<= (+ new-lower n) limit)
;; 駒の移動
(vector-set! board space p)
(vector-set! board x 0)
(dfs (+ n 1) limit x (cons p move) new-lower)
;; 元に戻す
(vector-set! board x p)
(vector-set! board space 0))))))
(vector-ref *adjacent* space)))))
;;
(let ((lower (calc-distance board)))
(let loop ((i lower))
(when
(<= i 31)
(display "-----") (display i) (display "-----\n")
(dfs 0 i (vector-position zero? board) '(-1) lower)
(when
(zero? found)
(loop (+ i 1)))))))
局所関数 dfs の引数 lower は現在の盤面 board の下限値を表しています。駒を動かしたら差分を計算して、新しい下限値 new-lower を求めます。そして、new-lower + n が上限値 limit を越えたら枝刈りを行います。limit 以下であれば dfs を再帰呼び出しします。追加する処理はこれだけで、あとは反復深化のプログラムと同じです。とても簡単ですね。
最後に dfs を呼び出す処理を修正します。関数 calc-distance で初期状態の下限値 lower を求めます。下限値がわかるのですから、上限値 limit は 1 手からではなく下限値 lower からスタートします。あとは dfs に下限値 lower を渡して呼び出すだけです。
プログラムの主な修正はこれだけです。実際に実行してみると、実行時間は 0.3 秒でした。約 600 倍という高速化に驚いてしまいました。下限値枝刈り法の効果は極めて高いですね。
;;;
;;; eight3.scm : 8 Puzzle (反復深化による解法)
;;;
;;; Copyright (C) 2008-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write))
;;; 隣接リスト
(define *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
;;; 見つけたデータの位置を返す
(define (vector-position p vs)
(do ((k (vector-length vs))
(i 0 (+ i 1)))
((or (>= i k)
(p (vector-ref vs i)))
(if (< i k) i #f))))
;;; 単純な反復深化
(define (solver board goal)
;; フラグ
(define found 0)
;; 反復深化
(define (dfs n limit space move)
(cond
((= n limit)
(when
(equal? board goal)
(set! found (+ found 1))
(display (cdr (reverse move)))
(newline)))
(else
(for-each
(lambda (x)
(let ((p (vector-ref board x)))
(unless
(= (car move) p)
;; 駒の移動
(vector-set! board space p)
(vector-set! board x 0)
(dfs (+ n 1) limit x (cons p move))
;; 元に戻す
(vector-set! board x p)
(vector-set! board space 0))))
(vector-ref *adjacent* space)))))
;
(let loop ((i 1))
(when
(<= i 31)
(display "-----") (display i) (display "-----\n")
(dfs 0 i (vector-position zero? board) '(-1))
(when
(zero? found)
(loop (+ i 1))))))
;;;
;;; 下限値枝刈り法
;;;
; 移動距離
(define *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)))
;;; アクセス関数
(define (get-distance piece pos)
(vector-ref (vector-ref *distance* piece) pos))
;;; 移動距離を求める
(define (calc-distance board)
(let loop ((i 0) (d 0))
(if (<= (vector-length board) i)
d
(let ((p (vector-ref board i)))
(loop
(+ i 1)
(+ d (get-distance p i)))))))
;;; 反復深化 (下限値枝刈り法)
(define (solver2 board goal)
;; フラグ
(define found 0)
;; 反復深化
(define (dfs n limit space move lower)
(cond
((= n limit)
(when
(equal? board goal)
(set! found (+ found 1))
(display (cdr (reverse move)))
(newline)))
(else
(for-each
(lambda (x)
(let ((p (vector-ref board x)))
(unless
(= (car move) p)
;; 下限値枝刈り法
(let ((new-lower (+ (- lower (get-distance p x)) (get-distance p space))))
(when
(<= (+ new-lower n) limit)
;; 駒の移動
(vector-set! board space p)
(vector-set! board x 0)
(dfs (+ n 1) limit x (cons p move) new-lower)
;; 元に戻す
(vector-set! board x p)
(vector-set! board space 0))))))
(vector-ref *adjacent* space)))))
;;
(let ((lower (calc-distance board)))
(let loop ((i lower))
(when
(<= i 31)
(display "-----") (display i) (display "-----\n")
(dfs 0 i (vector-position zero? board) '(-1) lower)
(when
(zero? found)
(loop (+ i 1)))))))
;;; 実行
;(solver #(8 6 7 2 5 4 3 0 1) #(1 2 3 4 5 6 7 8 0))
(solver2 #(8 6 7 2 5 4 3 0 1) #(1 2 3 4 5 6 7 8 0))