パズルに挑戦！
今回は 5 つのパズルを出題します。Common Lisp で解法プログラムを作成してください。
●問題１「騎士の巡歴」
ナイト (騎士) はチェスの駒のひとつで将棋の桂馬の動きを前後左右にとることができます。次の図を見てください。
図 : 騎士の巡歴 (Knight's Tour)
このナイトを動かして、N 行 M 列の盤面のどのマスにもちょうど一回ずつ訪れるような経路を求めるのが問題です。ちなみに、3 行 3 列、4 行 4 列の盤面には解がありませんが、5 行 5 列の盤面には解があります。大きな盤面を解くのは大変なので、3 行 4 列の盤面でナイトの移動経路を求めてください。プログラムを作る前に自分で考えてみるのも面白いでしょう。
●問題２「騎士の交換」
次は黒騎士 ● と白騎士 ○ の位置を交換するパズルです。それでは問題です。
図 : 騎士の交換
上図の START から GOAL までの最短手順を求めてください。
●問題３「地図の配色」
「地図の配色問題」は、平面上にある隣り合った地域が同じ色にならないように塗り分けるという問題です。1976 年にアッペルとハーケンにより、どんな場合でも 4 色あれば塗り分けできることが証明されました。これを「四色問題」といいます。今回は、次に示す簡単な地図を塗り分けてみてください。
図 : 簡単な地図
この程度の大きさの地図であれば、私達でも解くことができると思います。気分転換や息抜きのときに考えてみてください。ちなみに、3 色では解けません。
●問題４「どこも平方数」
1 から N までの数字を 1 個ずつ 1 列に並べます。このとき、隣り合う数字の和が平方数になる並べ方が存在する、N の最小値を求めてください。余裕のある方は、先頭と末尾をつなげたリング状に並べる条件で、N の最小値を求めてみてください。
芦ヶ原伸之, 『ブルーバックス B-1377 超々難問数理パズル 解けるものなら解いてごらん』, 講談社, 2002
●問題5「11 パズル」
最後に、8 パズルを大きくした 11 パズルを解いてみましょう。高橋謙一郎さん の １１パズルの最適解が最長手数となる面の探索 によると、11 パズルの最長手数は 53 手で、局面は全部で 18 通りあるそうです。そのうちの一つを下図に示します。
図 : 11 パズル (最長手数局面) (出典 : １１パズルの最適解が最長手数となる面の探索)
左図から右図の完成形までの最短手順を求めてください。
●解答１
それではプログラムを作りましょう。ナイトの移動経路を図に示すと次のようになります。
図 (Ａ) のように、3 行 4 列盤の各マスに番号をつけて表します。すると、ナイトの移動は (Ｂ) のようにグラフで表すことができます。これならばコンピュータを使わなくても解くことができますね。プログラムも隣接リストを定義すれば簡単です。次のリストを見てください。
リスト : 騎士の巡歴
;;; 隣接リスト
(defconstant adjacent
#((5 7) ; 0
(6 8) ; 1
(3 7) ; 2
(2 8 10) ; 3
(9 11) ; 4
(0 6 10) ; 5
(1 5 11) ; 6
(0 2) ; 7
(1 3 9) ; 8
(4 8) ; 9
(3 5) ; 10
(4 6))) ; 11
;;; 深さ優先探索
(defun knight-tour (&optional (path '(0)))
(if (= (length path) 12)
(print (reverse path))
(dolist (x (aref adjacent (car path)))
(unless (member x path)
(knight-tour (cons x path))))))
隣接リストはベクタ adjacent に定義します。関数 knight-tour は単純な深さ優先探索です。引数 PATH にナイトの経路を格納します。PATH の長さが 12 になったら、すべての場所を訪問したので print で経路 (reverse path) を表示します。そうでなければ、隣接リスト adjacent から次の場所 X を選んで騎士を移動します。このとき、member で PATH に X が含まれていないことを確認します。
これでプログラムは完成です。さっそく実行してみましょう。
* (knight-tour) (0 7 2 3 10 5 6 1 8 9 4 11) (0 7 2 3 10 5 6 11 4 9 8 1) NIL
2 通りの経路を見つけることができました。このプログラムでは隣接リストを使いましたが、盤面を 2 次元配列で表しても簡単にプログラムできます。興味のある方は挑戦してみてください。
●解答２
このパズルは 12 マスに 3 個の黒騎士を置き、残りの 9 マスに白騎士を置くわけですから、局面の総数は次のようになります。
12Ｃ3 * 9Ｃ3 = 220 * 84 = 18480 通り
それほど多くありませんね。今回はオーソドックスに幅優先探索でパズルを解いてみましょう。プログラムは次のようになります。
リスト : 騎士の交換
(defun knight-change (&optional (start #(1 1 1 0 0 0 0 0 0 2 2 2))
(goal #(2 2 2 0 0 0 0 0 0 1 1 1)))
(let ((que (make-queue))
(ht (make-hash-table :test #'equalp)))
(enqueue que (list nil start))
(setf (gethash start ht) t)
(loop
(if (emptyp que) (return))
(let ((state (dequeue que)))
(dotimes (from 12)
;; knight があるか
(unless (empty-placep state from)
(dolist (to (aref adjacent from))
;; 移動先が空き場所か
(when (empty-placep state to)
(let* ((board (make-board state from to))
(newst (list state board)))
;; 同じ盤面があるか
(unless (gethash board ht)
(enqueue que newst)
(setf (gethash board ht) t)
(when (equalp board goal)
(print-answer newst)
(return-from knight-change))))))))))))
盤面はベクタで表します。関数 knight-change の引数 STARR がスタートの盤面、GOAL がゴールの盤面です。キューは パッケージの基本的な使い方 で作成した queue.lisp を、隣接リストは「騎士の巡歴」で定義したベクタ adjacent を使います。局面はリストで表していて、先頭要素が一つ前の局面、二番目の要素が盤面です。盤面のチェックにはハッシュ表を使います。
最初に START の局面をキュー QUE に追加して、ハッシュ表 HT に START を登録します。あとは、キューから STATE を取り出し、ナイトを動かして新しい盤面を作ります。変数 FROM が動かすナイトの位置、TO が移動先の位置です。関数 empty-placep は STATE で N 番目の要素が空き (0) ならば真を返します。FROM にナイトがあり、TO が空き場所であれば、ナイトを動かすことができます。関数 make-board で新しい盤面 BOARD を生成します。
そして、ハッシュ表 HT で board と同じ盤面がないかチェックします。新しい盤面であれば、その局面 NEWST をキュー QUE に、BOARD をハッシュ表 HT に登録します。BOARD が GOAL に等しい場合、ゴールに到達したので、関数 print-answer で手順を表示して、return-from で幅優先探索を終了します。
あとのプログラムは簡単なので説明は割愛します。詳細は プログラムリスト２ をお読みください。
●実行結果
これでプログラムは完成です。さっそく実行してみましょう。
(time (knight-change)) #(1 1 1 0 0 0 0 0 0 2 2 2) #(0 1 1 0 0 1 0 0 0 2 2 2) #(0 1 0 1 0 1 0 0 0 2 2 2) #(0 1 0 0 0 1 0 0 1 2 2 2) #(0 1 0 2 0 1 0 0 1 2 0 2) #(0 1 2 0 0 1 0 0 1 2 0 2) #(0 1 2 0 0 0 0 0 1 2 1 2) #(0 1 2 1 0 0 0 0 0 2 1 2) #(0 1 2 1 0 0 0 0 2 0 1 2) #(0 1 2 1 0 0 2 0 2 0 1 0) #(0 1 2 1 0 2 0 0 2 0 1 0) #(0 0 2 1 0 2 1 0 2 0 1 0) #(2 0 2 1 0 0 1 0 2 0 1 0) #(2 0 2 1 0 0 0 0 2 0 1 1) #(2 2 2 1 0 0 0 0 0 0 1 1) #(2 2 2 0 0 0 0 0 1 0 1 1) #(2 2 2 0 0 0 0 0 0 1 1 1) Evaluation took: 0.060 seconds of real time 0.051986 seconds of total run time (0.051986 user, 0.000000 system) 86.67% CPU 124,752,566 processor cycles 20,394,368 bytes consed NIL 実行環境 : SBCL 2.1.11, Ubunts 22.04 (WSL2), Intel Core i5-6200U 2.30GHz
最短手数は 16 手になりました。
●プログラムリスト２
リスト : 騎士の交換
(require :queue "queue.lisp")
(use-package :queue)
;;; 隣接リスト
(defconstant adjacent
#((5 7) ; 0
(6 8) ; 1
(3 7) ; 2
(2 8 10) ; 3
(9 11) ; 4
(0 6 10) ; 5
(1 5 11) ; 6
(0 2) ; 7
(1 3 9) ; 8
(4 8) ; 9
(3 5) ; 10
(4 6))) ; 11
;;; 手順の表示
(defun print-answer (state)
(when (car state)
(print-answer (car state)))
(print (second state)))
;;; 新しい盤面の生成
(defun make-board (state from to)
(let ((board (copy-seq (second state))))
(setf (aref board to) (aref board from)
(aref board from) 0)
board))
;;; 空き場所か？
(defun empty-placep (state n)
(zerop (aref (second state) n)))
;;; 騎士の交換
(defun knight-change (&optional (start #(1 1 1 0 0 0 0 0 0 2 2 2))
(goal #(2 2 2 0 0 0 0 0 0 1 1 1)))
(let ((que (make-queue))
(ht (make-hash-table :test #'equalp)))
(enqueue que (list nil start))
(setf (gethash start ht) t)
(loop
(if (emptyp que) (return))
(let ((state (dequeue que)))
(dotimes (from 12)
;; knight があるか
(unless (empty-placep state from)
(dolist (to (aref adjacent from))
;; 移動先が空き場所か
(when (empty-placep state to)
(let* ((board (make-board state from to))
(newst (list state board)))
;; 同一局面があるか
(unless (gethash board ht)
(enqueue que newst)
(setf (gethash board ht) t)
(when (equalp board goal)
(print-answer newst)
(return-from knight-change))))))))))))
●解答３
それではプログラムを作りましょう。今回の問題は単純な深さ優先探索で簡単に解くことができます。順番に地域の色を決めていきますが、このときに隣接している地域と異なる色を選びます。もし、色を選ぶことができなければ、バックトラックして前の地域に戻り違う色を選びます。
地域 A - L は番号 0 - 11 で表すことにします。地図はグラフで表すことができるので、いつものように隣接リストを使いましょう。地域の色はベクタ BOARD に格納します。まだ色を塗っていない状態を 0 で表し、1 から 4 までの数値で色を表します。たとえば、地域 G に色 1 を塗るのであれば、隣接する地域で色 1 が使われていないことを確認すればいいわけです。
プログラムは次のようになります。
リスト：地図の配色問題
;;; 隣接リスト
(defconstant neighbors
#((1 2 3 5 10 11) ; 0
(0 3 4 8 11) ; 1
(0 3 5 6) ; 2
(0 1 2 4 6 7) ; 3
(1 3 7 8) ; 4
(0 2 6 9 10) ; 5
(2 3 5 7 9) ; 6
(3 4 6 8 9) ; 7
(1 4 7 9 11) ; 8
(5 6 7 8 10 11) ; 9
(0 5 9 11) ; 10
(0 1 8 9 10))) ; 11
;;; 深さ優先探索
(defun color-map-sub (color n board)
(if (= (length board) n)
(print board)
(loop for c from 1 to color
when (loop for x in (aref neighbors n) always (/= c (aref board x)))
do (setf (aref board n) c)
(color-map-sub color (1+ n) board)
(setf (aref board n) 0))))
(defun color-map (color)
(let ((board (make-array (length neighbors) :initial-element 0)))
(setf (aref board 0) 1)
(color-map-sub color 1 board)))
実際の処理は関数 color-map-sub で行います。color-map-sub は単純な深さ優先探索です。引数 N は地域の番号を表し、COLOR は色の種類を表します。今回は地域 A (0) の色を 1 に限定して、地域 B (1) から色を割り当てていきます。ループマクロの変数 C が色を表していて、値は 1 から COLOR までになります。
隣接の地域に同じ色が使われていないかチェックする処理もループマクロを使っています。隣接リスト NEIGHBORS から隣接する領域を取り出し、すべての領域で C と異なる色であることを確かめます。そうであれば、BOARD の N 番目に C をセットして color-map-sub を再帰呼び出しします。
●実行結果
それではプログラムを実行してみましょう。次のように、色の種類を増やして地図を塗り分けることができるか試していきます。
* (color-map 2) NIL * (color-map 3) NIL * (color-map 4) #(1 2 2 3 1 3 4 2 3 1 2 4) #(1 2 2 3 1 3 4 2 4 1 2 3) #(1 2 2 3 1 3 4 2 4 1 4 3) ・・・省略・・・ #(1 4 4 3 2 2 1 4 1 3 4 2) #(1 4 4 3 2 3 1 4 1 2 4 3) #(1 4 4 3 2 3 2 4 3 1 4 2) NIL
地域 A の色を 1 に限定すると 54 通りの解が出力されます。最初に表示される解を下図に示します。
図 : 地図の色分け解答例
今回は 12 の地域しかないので、単純な深さ優先探索で簡単に解くことができました。地域の数がもっと増えると、探索に時間がかかるようになるかもしれません。興味のある方は挑戦してみてください。
●解答４
このパズルは、N が小さいときには単純な生成検定法 (順列を生成して条件を満たしているかチェックする方法) でも解けそうですが、N が大きくなるにつれて時間がかかるようになります。そこで、隣接リストと同じように、隣に置くことができる数字をあらかじめ求めておくことにしましょう。プログラムは次のようになります。
リスト : 隣接リストの生成
;;; n 以下の平方数の生成
(defun make-squares (n &optional (m 2))
(if (< n (* m m))
nil
(cons (* m m)
(make-squares n (1+ m)))))
;;; 隣接リストの生成
(defun make-neighbors (n)
(let ((table (make-array (1+ n) :initial-element nil))
(xs (make-squares (+ n (1- n)))))
(do ((i 1 (1+ i)))
((< n i) table)
(setf (aref table i)
(remove-if-not (lambda (x) (and (/= x i) (<= 1 x n)))
(mapcar (lambda (j) (- j i)) xs))))))
関数 make-squares は引数 N 以下の平方数を格納したリストを生成します。たとえば、1 から 15 までの数字でパズルを解く場合、最大値は 15 + 14 = 29 になります。make-squares に 29 を渡すと、1 を除いた平方数を格納したリスト (4 9 16 25) を返します。
関数 make-neighbors は隣に置くことができる数字を格納した隣接リストを返します。隣接リストはベクタ TABLE に格納します。変数 XS には N + N - 1 以下の平方数を格納したリストをセットします。あとは、do ループで 1 から N までの数字に対して、隣に置くことができる数字を求めて TABLE にセットします。
まず mapcar で平方数 J から I を引いた数を求め、その中から 1 から N の範囲内に入る数を remove-if-not で選択します。たとえば、N が 15 で I が 1 の場合、リスト (4 9 16 25) は mapcar で (3 8 15 24) に変換され、remove-if-not で 24 が取り除かれて (3 8 15) が残ります。
それでは実際に実行してみましょう。
* (loop for x from 4 to 15 do (print (make-neighbors x))) #(NIL (3) NIL (1) NIL) #(NIL (3) NIL (1) (5) (4)) #(NIL (3) NIL (1 6) (5) (4) (3)) #(NIL (3) (7) (1 6) (5) (4) (3) (2)) #(NIL (3 8) (7) (1 6) (5) (4) (3) (2) (1)) #(NIL (3 8) (7) (1 6) (5) (4) (3) (2 9) (1) (7)) #(NIL (3 8) (7) (1 6) (5) (4) (3 10) (2 9) (1) (7) (6)) #(NIL (3 8) (7) (1 6) (5) (4 11) (3 10) (2 9) (1) (7) (6) (5)) #(NIL (3 8) (7) (1 6) (5 12) (4 11) (3 10) (2 9) (1) (7) (6) (5) (4)) #(NIL (3 8) (7) (1 6 13) (5 12) (4 11) (3 10) (2 9) (1) (7) (6) (5) (4 13) (3 12)) #(NIL (3 8) (7 14) (1 6 13) (5 12) (4 11) (3 10) (2 9) (1) (7) (6) (5 14) (4 13) (3 12) (2 11)) #(NIL (3 8 15) (7 14) (1 6 13) (5 12) (4 11) (3 10) (2 9) (1) (7) (6 15) (5 14) (4 13) (3 12) (2 11) (1 10)) NIL
N が 2, 3 の場合、解が無いことはすぐにわかります。N が 4, 5, 6 の場合、隣接リストに NIL が含まれているので、解は存在しません。また、隣に置くことができる数字がひとつしかない場合、その数字は両端に置くことしかできません。つまり、長さが 1 のリストが 2 つより多いと、解が無いことがわかります。N が 7 から 14 の場合がこれに該当します。
N が 15 の場合、両端の数字が 8 と 9 であれば解があるかもしれません。なお、ほとんどのリストは長さが 2 なので、手作業でも簡単に解くことができると思います。興味のある方は挑戦してみてください。
あとは深さ優先探索で解を求めます。次のリストを見てください。
リスト : パズル「どこも平方数」の解法
;;; 深さ優先探索
(defun dfs (fn board &optional (n 1))
(if (= n (length board))
(funcall fn board)
(dolist (x (aref *neighbors* (aref board (1- n))))
(unless (find x board :end n)
(setf (aref board n) x)
(dfs fn board (1+ n))
(setf (aref board n) 0)))))
(defun solver ()
(do ((n 15 (1+ n)))
((> n 20))
(format t "----- ~d -----~%" n)
(setq *neighbors* (make-neighbors n))
(let ((board (make-array n :initial-element 0)))
(dotimes (i n)
(setf (aref board 0) (1+ i))
(dfs (lambda (x) (print x) (return-from solver)) board)))))
関数 dfs の引数 FN が解を見つけたときに実行する関数、BOARD が盤面を表すベクタ、N が数字を置く場所を表します。dfs は BOARD の 0 番目の数字を決めてから呼び出すことに注意してください。
N が BOARD の長さと同じ値になったならば、解を見つけたので関数 FN を実行します。そうでなければ、BOARD の N - 1 番目の数字の隣接リストを *NEIGHBORS* から求め、dolist で順番に取り出して変数 X にセットします。X が BOARD の区間 [0, N) で未使用ならば、BOARD の N 番目に X を書き込んで dfs を再帰呼び出しします。
関数 solver は do ループで N の値を増やし、dotimes で BOARD の 0 番目に数字 I をセットしてから dfs を呼び出します。
それでは実行してみましょう。
* (solver) ----- 15 ----- #(8 1 15 10 6 3 13 12 4 5 11 14 2 7 9) NIL
N が 15 のとき、条件を満たすように数字を並べることができました。
●数字をリング状に並べる場合
リスト : リング状に並べる場合
;;; 深さ優先探索
(defun dfs-ring (fn board &optional (n 1))
(if (= n (length board))
(when (member (aref board (1- n)) (aref *neighbors* (aref board 0)))
(funcall fn board))
(dolist (x (aref *neighbors* (aref board (1- n))))
(unless (find x board :end n)
(setf (aref board n) x)
(dfs-ring fn board (1+ n))
(setf (aref board n) 0)))))
(defun solver-ring ()
(do ((n 15 (1+ n)))
((> n 40))
(format t "----- ~d -----~%" n)
(setq *neighbors* (make-neighbors n))
(let ((board (make-array n :initial-element 0)))
(setf (aref board 0) 1)
(dfs-ring (lambda (x) (print x) (return-from solver-ring)) board))))
数字をリング状に並べる場合、深さ優先探索 (関数 dfs-ring) の最後で、末尾の数字が先頭の数字の隣接リストに含まれているか member でチェックします。solver-ring で dfs-ring を呼び出すときは、BOARD の 0 番目に 1 をセットします。盤面はリング状なので、1 から N までの数字であれば、何でもかまいません。
実行結果は次のようになりました。
* (solver-ring) ----- 15 ----- ----- 16 ----- ----- 17 ----- ----- 18 ----- ----- 19 ----- ----- 20 ----- ----- 21 ----- ----- 22 ----- ----- 23 ----- ----- 24 ----- ----- 25 ----- ----- 26 ----- ----- 27 ----- ----- 28 ----- ----- 29 ----- ----- 30 ----- ----- 31 ----- ----- 32 ----- #(1 8 28 21 4 32 17 19 30 6 3 13 12 24 25 11 5 31 18 7 29 20 16 9 27 22 14 2 23 26 10 15) NIL
N = 32 で条件を満たすように数字を並べることができました。
●解答５
プログラムは基本的に 8 パズルの「反復深化＋下限値枝刈り法」と同じです。ただし、そのままでは時間がかかるので、「手数の偶奇性」というパズルの性質を使って、探索の上限値を 2 手ずつ増やすことにします。
●手数の偶奇性
8 パズルや 15 パズルの場合、スタートの空き場所の位置とゴールの空き場所の位置から、解の手数が偶数になるのか奇数になるのか簡単に判定することができます。この場合、探索の上限値を 1 手ずつではなく 2 手ずつ増やすことができるので、実行時間を短縮することが可能です。
判定は簡単です。次の図を見てください。
図 : 手数の偶奇性
盤面を市松模様に塗り分けます。上図のパリティでは 0 と 1 で表しています。スタートからゴールに到達するまで、空き場所はいろいろな位置に移動しますが、同じパリティの位置に移動する場合は偶数回かかり、異なるパリティの位置に移動する場合は奇数回かかります。
たとえば、スタートで駒 5 を 1 回動かすと、空き場所は上の位置に移動します。この場合、移動回数は奇数でパリティの値は 0 から 1 に変わります。スタートから駒 5 と 6 を動かすと、移動回数は偶数でパリティの値は 0 のままです。このように、同じパリティの位置に移動する場合は偶数回、異なるパリティの位置に移動する場合は奇数回となります。上図のスタートとゴールの場合、空き場所のパリティが異なるので、奇数回かかることがわかります。
プログラムは 8 パズルの「反復深化＋下限値枝刈り法」に「手数の偶奇性」の処理を追加しただけです。説明は割愛するので、詳細は プログラムリスト５ をお読みください。
●実行結果
実行結果は次のようになりました。
* (time (solver-id-lower #(0 3 2 1 8 7 6 5 4 11 10 9) #(1 2 3 4 5 6 7 8 9 10 11 0))) ----- 23 ----- ----- 25 ----- ----- 27 ----- ----- 29 ----- ----- 31 ----- ----- 33 ----- ----- 35 ----- ----- 37 ----- ----- 39 ----- ----- 41 ----- ----- 43 ----- ----- 45 ----- ----- 47 ----- ----- 49 ----- ----- 51 ----- ----- 53 ----- (3 2 6 5 1 6 2 7 5 1 9 10 11 4 8 5 1 9 10 11 4 8 5 1 9 10 11 4 8 9 10 2 7 3 1 5 9 10 2 11 4 8 11 7 6 4 7 6 3 2 6 7 8) Evaluation took: 51.020 seconds of real time 51.016084 seconds of total run time (50.927965 user, 0.088119 system) [ Run times consist of 0.272 seconds GC time, and 50.745 seconds non-GC time. ] 99.99% CPU 122,457,148,764 processor cycles 1 page fault 9,168,285,680 bytes consed NIL 実行環境 : SBCL 2.1.11, Ubunts 22.04 (WSL2), Intel Core i5-6200U 2.30GHz
当然ですが手数は 53 手、実行時間は約 51 秒でした。
●プログラムリスト５
リスト : 11 パズルの解法
;;; 盤面
;;; 0 1 2 3
;;; 4 5 6 7
;;; 8 9 10 11
;;; 隣接リスト
(defconstant adjacent
#((1 4) ; 0
(0 2 5) ; 1
(1 3 6) ; 2
(2 7) ; 3
(0 5 8) ; 4
(1 4 6 9) ; 5
(2 5 7 10) ; 6
(3 6 11) ; 7
(4 9) ; 8
(5 8 10) ; 9
(6 9 11) ; 10
(7 10))) ; 11
;;; 距離
(defconstant distance
#2A((0 0 0 0 0 0 0 0 0 0 0 0) ; 0 dummy
(0 1 2 3 1 2 3 4 2 3 4 5) ; 1
(1 0 1 2 2 1 2 3 3 2 3 4) ; 2
(2 1 0 1 3 2 1 2 4 3 2 3) ; 3
(3 2 1 0 4 3 2 1 5 4 3 2) ; 4
(1 2 3 4 0 1 2 3 1 2 3 4) ; 5
(2 1 2 3 1 0 1 2 2 1 2 3) ; 6
(3 2 1 2 2 1 0 1 3 2 1 2) ; 7
(4 3 2 1 3 2 1 0 4 3 2 1) ; 8
(2 3 4 5 1 2 3 4 0 1 2 3) ; 9
(3 2 3 4 2 1 2 3 1 0 1 2) ; 10
(4 3 2 3 3 2 1 2 2 1 0 1))) ; 11
;;; パリティ
(defconstant parity
#(1 0 1 0 0 1 0 1 1 0 1 0))
;;; 移動距離を求める
(defun calc-distance (board)
(loop for i from 0
for j across board
sum (aref distance j i)))
;;; 最初の上限値を求める
(defun get-start-limit (start goal lower)
(cond
((= (aref parity (position 0 start))
(aref parity (position 0 goal)))
(if (evenp lower) lower (1+ lower)))
((oddp lower) lower)
(t (1+ lower))))
;;; 下限値枝刈り法
(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)
(loop with lower = (calc-distance start)
for i from (get-start-limit start goal lower) to 53 by 2
do
(format t "----- ~d -----~%" i)
(dfs-lower
(lambda (xs) (format t "~a~%" xs) (return-from solver-id-lower))
start
goal
0
i
(position 0 start)
'(-1)
lower)))
改訂 2023 年 7 月 16 日