Common Lisp 入門 の番外編です。今回はパズル「フリップ・イット」の解法プログラムを Common Lisp で作ってみましょう。なお、このドキュメントは拙作のページ Memorandum で取り上げたパズル「フリップ・イット」をまとめたものです。内容は重複していますが、ご了承くださいませ。
「フリップ・イット (Flip It)」は芦ヶ原伸之氏が考案されたパズルで、すべての駒を裏返しにするのが目的です。今回はリバーシの駒を使うことにしましょう。次の図を見てください。
０ １ ２ ３ ４ ５ ０ １ ２ ３ ４ ５
┌─┬─┬─┬─┬─┬─┐ ┌─┬─┬─┬─┬─┬─┐
│ │●│●│●│●│●│ │●│○│○│○│○│ │
└─┴─┴─┴─┴─┴─┘ └─┴─┴─┴─┴─┴─┘
│ │
┌─────────┘ └─────┐
↓ ↓
┌─┬─┬─┬─┬─┬─┐ ┌─┬─┬─┬─┬─┬─┐
│●│○│○│○│○│ │ │●│○│ │●│●│○│
└─┴─┴─┴─┴─┴─┘ └─┴─┴─┴─┴─┴─┘
５の駒が０へ跳んだ場合 ２の駒が５へ跳んだ場合
図：フリップ・イットのルール
フリップ・イットのルールは簡単です。ある駒は他の駒を跳び越して空き場所へ移動することができます。空き場所の隣にある駒は、跳び越す駒がないので移動できません。このとき、跳び越された駒は裏返しにされますが、跳んだ駒はそのままです。図では 5 の位置にある駒が 0 へ跳び、それから 2 の駒が 5 へ跳んだ場合を示しています。このあと 0 -> 2, 5 -> 0 と跳ぶと、すべての駒を白にすることができます。それでは問題です。
┌─┬─┬─┬─┬─┬─┐
(A) │●│●│ │●│●│●│
└─┴─┴─┴─┴─┴─┘
┌─┬─┬─┬─┬─┬─┬─┐
(B) │●│ │○│●│●│●│●│
└─┴─┴─┴─┴─┴─┴─┘
┌─┬─┬─┬─┬─┬─┬─┬─┐
(C) │●│ │○│○│○│●│●│●│
└─┴─┴─┴─┴─┴─┴─┴─┘
問題：フリップ・イット
参考文献 [1] の問題は 4 つの駒を使っているので、ここでは駒の個数を増やしてみました。すべての駒を白にする最短手順を求めてください。
それではプログラムを作りましょう。アルゴリズムは単純な反復深化を使います。盤面は Lisp らしくリストで表しましょう。要素はシンボルで、nil が黒、t が白、space が空き場所を表します。
最初に、駒を動かして新しい盤面を生成する関数 move-piece を作ります。次のリストを見てください。
リスト：駒の移動
(defun move-piece (n board piece start end)
(cond ((null board) nil)
((or (= n start) (= n end))
(cons (if (eq (car board) 'space) piece 'space)
(move-piece (1+ n) (cdr board) piece start end)))
((< start n end)
(cons (not (car board))
(move-piece (1+ n) (cdr board) piece start end)))
(t (cons (car board)
(move-piece (1+ n) (cdr board) piece start end)))))
引数 n が盤面の位置、board が盤面、piece が移動する駒の種類、start と end (start < end) が移動する駒の位置と空き場所の位置です。move-piece は board をコピーするとともに、start と end の間の駒を裏返しにして、start と end の位置にある piece と space を入れ替えます。駒の裏返しは not を使えば簡単です。
次は、反復深化で最短手順を探索する関数 solve-id を作ります。
リスト：反復深化による探索
(defun solve-id (n limit board space history)
(if (= limit n)
(when (zerop (count nil board))
(print-answer board history)
(throw 'find-answer t))
(dotimes (x (length board))
(when (and (not (eql (cdar history) x))
(or (< x (1- space)) (< (1+ space) x)))
; 移動可能
(solve-id (1+ n)
limit
(move-piece 0 board (nth x board) (min x space) (max x space))
x
(cons (cons x space) history))))))
引数 n が手数、limit が反復深化の上限値、board が盤面、space が空き場所の位置、history が移動手順を表すリストです。history の要素はドット対 (動かす駒の位置 . 空き場所の位置) です。
手数 n が上限値 limit になったならば、駒がすべて白になったかチェックします。関数 count で nil の個数を数え、その値が 0 であれば黒の駒はありません。関数 print-answer で手順を表示してから、throw で大域脱出して探索を終了します。
フリップ・イットは、同じ駒を続けて動かすと元の状態に戻ってしまいます。そこで、動かす駒の位置 x が 1 手前の空き場所の位置 (cdar history) と同じ場合は、その駒を動かさないようにします。history の初期値は nil なので、比較には eql を使っています。このチェックがないと実行時間がとても遅くなります。ご注意くださいませ。
それから、フリップ・イットのルールでは、空き場所の隣の駒は動かすことができません。この条件を (or (< x (1- space)) (< (1+ space) x)) でチェックしています。ルールを「空き場所の隣の駒を動かしてもよい」ことに変更する場合は、(or ... ) の部分を (/= x space) に修正してください。
最後に、solve-id を呼び出す関数 flip-it-solver と手順を表示する関数 print-answer を作ります。
リスト：「フリップ・イット」解法プログラム
; 盤面を表示
(defun print-board (board)
(let ((code '((nil . "●") (t . "○") (space . "＿"))))
(dolist (piece board (terpri))
(format t "~A " (cdr (assoc piece code))))))
; 手順を表示
(defun print-answer (board history)
(let ((s (caar history))
(p (cdar history)))
(if history
(print-answer (move-piece 0 board (nth p board) (min p s) (max p s))
(cdr history)))
(print-board board)))
; フリップ・イットを解く
(defun flip-it-solver (start)
(catch 'find-answer
(dotimes (limit 20)
(format t "***** ~D 手を探索 *****~%" (1+ limit))
(solve-id 0 (1+ limit) start (position 'space start) nil))))
flip-it-solver は、反復深化の上限値 limit を 1 手ずつ増やして solve-id を呼び出すだけです。print-answer は history から盤面を再現して手順を表示します。引数 board が現在の盤面で history が移動手順です。再帰呼び出しで最初の状態に戻してから print-board で盤面を表示します。盤面 board を 1 手前に戻すとき、history の先頭要素を (s . p) とすると、board の p の位置に駒があり、s の位置が空き場所であることに注意してください。
これでプログラムは完成です。詳細は プログラムリスト１ をお読みください。
それでは、「フリップ・イット」の解答を示します。図では空き場所を ＿ で表しています。
（Ａ） （Ｂ） （Ｃ）
0: ● ● ＿ ● ● ● ● ＿ ○ ● ● ● ● ● ＿ ○ ○ ○ ● ● ●
1: ＿ ○ ● ● ● ● ● ● ● ＿ ● ● ● ● ○ ● ＿ ○ ● ● ●
2: ● ● ○ ＿ ● ● ＿ ○ ○ ● ● ● ● ＿ ● ○ ● ○ ● ● ●
3: ● ● ○ ● ○ ＿ ○ ● ＿ ● ● ● ● ○ ○ ＿ ● ○ ● ● ●
4: ● ● ＿ ○ ● ○ ○ ● ● ○ ＿ ● ● ○ ○ ○ ○ ＿ ● ● ●
5: ＿ ○ ● ○ ● ○ ○ ● ● ○ ● ○ ＿ ○ ○ ○ ○ ● ○ ○ ＿
6: ○ ● ○ ＿ ● ○ ○ ● ● ＿ ○ ● ○ ＿ ● ● ● ○ ● ● ○
7: ○ ＿ ● ● ● ○ ○ ● ● ● ● ＿ ○ ○ ○ ○ ○ ＿ ● ● ○
8: ○ ○ ○ ○ ○ ＿ ＿ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ○ ＿
図：フリップ・イットの解答
(A), (B), (C) ともに最短手数は 8 手になりました。実は、これが最長手数の局面となります。ちなみに、駒の個数が 4 つの場合だと、最長手数は 10 手と長くなります。また、最後の白石の位置を限定すると、手数が長くなる場合もあります。たとえば、(A) の問題でゴールを "＿ ○ ○ ○ ○ ○" とすると、最短手数は 9 手になります。興味のある方は、いろいろと試してみてください。
次は、最長手数の局面を幅優先探索で求めてみましょう。最初に、キューの大きさを決めるため石の置き方が何通りあるか数えます。これは空き場所の配置から考えた方が簡単です。盤面の大きさを N とすると、空き場所の配置は N 通りあります。残りは黒石か白石のどちらかなので、石の配置は 2 N - 1 通りあります。したがって、全体では N * 2 N - 1 通りになります。
実際に計算してみると、N = 6 で 192 通り、N = 7 で 448 通り、N = 8 で 1024 通りになります。大きな数ではないので、同一局面のチェックは線形探索でいいでしょう。プログラムは次のようになります。
リスト：「フリップ・イット」最長手数の探索
; 解の表示
(defun print-answer-max (n move-table state-table)
(let ((max (aref move-table n)))
(format t "最長手数 ~D 手~%" max)
(loop
(print (aref state-table n))
(decf n)
(if (/= max (aref move-table n)) (return)))))
; 最長手数の探索
(defun solve-max (board-size)
(let* ((max-state (* (expt 2 (1- board-size)) board-size))
(state-table (make-array max-state)) ; 盤面
(space-table (make-array max-state)) ; 空き場所の位置
(move-table (make-array max-state)) ; 手数
(rear 0)
(front 0)
board new-board space)
; キューの初期化
(dotimes (x board-size)
(setf board (make-list board-size :initial-element t)
(nth x board) 'space
(aref state-table rear) board
(aref space-table rear) x
(aref move-table rear) 0)
(incf rear))
; 探索
(while (< front rear)
(setq board (aref state-table front)
space (aref space-table front))
(dotimes (x board-size)
(when (or (< x (1- space)) (< (1+ space) x))
; 移動可能
(setq new-board (move-piece 0 board (nth x board) (min x space) (max x space)))
(unless (find new-board state-table :test #'equal)
; キューに登録
(setf (aref state-table rear) new-board
(aref space-table rear) x
(aref move-table rear) (1+ (aref move-table front)))
(incf rear))))
(incf front))
; 解の表示
(format t "状態数 ~D 個~%" rear)
(print-answer-max (1- rear) move-table state-table)))
関数 solve-max には盤面のサイズを渡します。最初に、キューの大きさを計算して変数 max-state にセットします。キューはベクタを使って定義します。state-table が盤面、space-table が空き場所の位置、move-table が移動手数を格納します。それぞれ make-array でベクタを生成して変数にセットします。
次に、キューを初期化します。ゴールの条件である「すべての石が白の盤面」を生成してキューにセットすれば OK です。make-list で要素が t のリストを生成して変数 board にセットし、空き場所の位置 x の要素を space に書き換えます。そして、盤面 board を state-table に、空き場所の位置 x を space-table に、手数 0 を move-table にセットします。キューを管理する変数 rear をインクリメントすることもお忘れなく。
あとは単純な幅優先探索です。同一局面のチェックには関数 find を使っています。比較するデータはリストなので、キーワード :test には #'equal を指定します。あとは特に難しいところはないでしょう。詳細は プログラムリスト２ をお読みくださいませ。
実行結果は次のようになりました。
(solve-max 5) (solve-max 6)
状態数 80 個 状態数 192 個
最長手数 10 手 最長手数 8 手
● ● ○ ＿ ● ● ＿ ○ ● ● ●
● ● ＿ ● ● ● ● ＿ ● ● ●
● ＿ ○ ● ● ● ● ● ○ ＿ ●
nil ● ● ● ＿ ● ●
nil
(solve-max 7) (solve-max 8)
状態数 448 個 状態数 1024 個
最長手数 8 手 最長手数 8 手
● ● ● ● ○ ＿ ● ● ● ＿ ● ● ● ● ●
● ● ● ● ＿ ● ● ● ＿ ○ ● ● ● ● ●
● ● ＿ ● ● ● ● ● ＿ ○ ○ ○ ● ● ●
● ＿ ○ ● ● ● ● ● ● ● ● ● ○ ＿ ●
nil ● ● ● ● ● ＿ ● ●
● ● ● ○ ○ ○ ＿ ●
nil
図：フリップ・イットの最長手数
フリップ・イットの場合、盤面を大きくしたからといって、最長手数が長くなるとは限らないようです。興味のある方は、より大きな盤面で試してみてください。
ところで、フリップ・イットのルールでは空き場所の隣の駒を動かすことはできません。ルールを「空き場所の隣の駒を動かしてもよい」ことに変更して最長手数の局面を求めてみたところ、結果は次のようになりました。
(solve-max 5) (solve-max 6) (solve-max 7)
状態数 80 個 状態数 192 個 状態数 448 個
最長手数 6 手 最長手数 6 手 最長手数 7 手
● ● ＿ ● ● ● ● ＿ ● ● ● ● ● ● ＿ ● ● ●
nil ● ● ○ ＿ ● ● ● ● ● ○ ＿ ● ●
● ＿ ○ ● ● ● ● ● ＿ ○ ● ● ●
● ● ● ＿ ● ● nil
● ● ● ○ ＿ ●
● ● ＿ ○ ● ●
nil
図：フリップ・イットの最長手数（別ルール）
(solve-max 8) の結果は、局面が多数あるため省略しましたが、最長手数は 7 手になりました。どうやら、このルールの方が簡単に解くことができるようです。
;
; flip_it.l : フリップ・イット 反復深化による解法
;
; Copyright (C) 2002,2003 Makoto Hiroi
;
;
; 盤面を表示
;
(defun print-board (board)
(let ((code '((nil . "●") (t . "○") (space . "＿"))))
(dolist (piece board (terpri))
(format t "~A " (cdr (assoc piece code))))))
;
; 手順を表示
;
(defun print-answer (board history)
(let ((s (caar history))
(p (cdar history)))
(if history
(print-answer (move-piece 0 board (nth p board) (min p s) (max p s))
(cdr history)))
(print-board board)))
;
; 駒を動かす
;
(defun move-piece (n board piece start end)
(cond ((null board) nil)
((or (= n start) (= n end))
(cons (if (eq (car board) 'space) piece 'space)
(move-piece (1+ n) (cdr board) piece start end)))
((< start n end)
(cons (not (car board))
(move-piece (1+ n) (cdr board) piece start end)))
(t (cons (car board)
(move-piece (1+ n) (cdr board) piece start end)))))
;
; 反復深化による探索
;
(defun solve-id (n limit board space history)
(if (= limit n)
(when (zerop (count nil board))
(print-answer board history)
(throw 'find-answer t))
(dotimes (x (length board))
(when (and (not (eql (cdar history) x))
(or (< x (1- space)) (< (1+ space) x)))
; 移動可能
(solve-id (1+ n)
limit
(move-piece 0 board (nth x board) (min x space) (max x space))
x
(cons (cons x space) history))))))
;
; フリップ・イットを解く
;
(defun flip-it-solver (start)
(catch 'find-answer
(dotimes (limit 20)
(format t "***** ~D 手を探索 *****~%" (1+ limit))
(solve-id 0 (1+ limit) start (position 'space start) nil))))
;
; flip_max.l : フリップ・イット 最長手数の探索
;
; Copyright (C) 2002,2003 Makoto Hiroi
;
;
; 駒を動かす
;
(defun move-piece (n board piece start end)
(cond ((null board) nil)
((or (= n start) (= n end))
(cons (if (eq (car board) 'space) piece 'space)
(move-piece (1+ n) (cdr board) piece start end)))
((< start n end)
(cons (not (car board))
(move-piece (1+ n) (cdr board) piece start end)))
(t (cons (car board)
(move-piece (1+ n) (cdr board) piece start end)))))
;
; 盤面を表示
;
(defun print-board (board)
(let ((code '((nil . "●") (t . "○") (space . "＿"))))
(dolist (piece board (terpri))
(format t "~A " (cdr (assoc piece code))))))
;
; 解の表示
;
(defun print-answer-max (n move-table state-table)
(let ((max (aref move-table n)))
(format t "最長手数 ~D 手~%" max)
(loop
(print-board (aref state-table n))
(decf n)
(if (/= max (aref move-table n)) (return)))))
;
; 最長手数の探索
;
(defun solve-max (board-size)
(let* ((max-state (* (expt 2 (1- board-size)) board-size))
(state-table (make-array max-state)) ; 盤面
(space-table (make-array max-state)) ; 空き場所の位置
(move-table (make-array max-state)) ; 手数
(rear 0)
(front 0)
board new-board space)
; キューの初期化
(dotimes (x board-size)
(setf board (make-list board-size :initial-element t)
(nth x board) 'space
(aref state-table rear) board
(aref space-table rear) x
(aref move-table rear) 0)
(incf rear))
; 探索
(while (< front rear)
(setq board (aref state-table front)
space (aref space-table front))
(dotimes (x board-size)
(when (or (< x (1- space)) (< (1+ space) x))
; 移動可能
(setq new-board (move-piece 0 board (nth x board) (min x space) (max x space)))
(unless (find new-board state-table :test #'equal)
; キューに登録
(setf (aref state-table rear) new-board
(aref space-table rear) x
(aref move-table rear) (1+ (aref move-table front)))
(incf rear))))
(incf front))
; 解の表示
(format t "状態数 ~D 個~%" rear)
(print-answer-max (1- rear) move-table state-table)))