お気楽 Common Lisp プログラミング入門

フリップ・イット (Flip It)

今回はパズル「フリップ・イット」の解法プログラムを Common Lisp で作ってみましょう。

●パズルの説明

「フリップ・イット (Flip It)」は芦ヶ原伸之氏が考案されたパズルで、すべての駒を裏返しにするのが目的です。今回はリバーシの駒を使うことにしましょう。次の図を見てください。

フリップ・イットのルールは簡単です。ある駒は他の駒を跳び越して空き場所へ移動することができます。空き場所の隣にある駒は、跳び越す駒がないので移動できません。このとき、跳び越された駒は裏返しにされますが、跳んだ駒はそのままです。図では 5 の位置にある駒が 0 へ跳び、それから 2 の駒が 5 へ跳んだ場合を示しています。このあと 0 -> 2, 5 -> 0 と跳ぶと、すべての駒を白にすることができます。それでは問題です。

参考文献 [1] の問題は 4 つの駒を使っているので、ここでは駒の個数を増やしてみました。すべての駒を白にする最短手順を求めてください。

-- 参考文献 --------
[1] 芦ヶ原伸之,『ブルーバックス B-1377 超々難問数理パズル解けるものなら解いてごらん』, 講談社, 2002

●プログラムの作成

それではプログラムを作りましょう。アルゴリズムは単純な反復深化を使います。盤面は 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 の位置が空き場所であることに注意してください。

これでプログラムは完成です。詳細はプログラムリスト１をお読みください。

●フリップ・イットの解答

それでは、「フリップ・イット」の解答を示します。図では空き場所を＿で表しています。

(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))
    ;; 探索
    (do ()
        ((>= 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 8) の結果は、局面が多数あるため省略しましたが、最長手数は 7 手になりました。どうやら、このルールの方が簡単に解くことができるようです。

●プログラムリスト１

;;;
;;; flipit.lisp : フリップ・イット 反復深化による解法
;;;
;;;               Copyright (C) 2003-2023 Makoto Hiroi
;;;

;;;
;;; 盤面を表示
;;;
(defun print-board (board)
  (let ((code '((nil . "●") (t . "○") (space . "＿"))))
    (dolist (piece board (terpri))
      (format t "~A " (cdr (assoc piece code))))))

;;;
;;; 駒を動かす
;;;
(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-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 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))))

●プログラムリスト２

;;;
;;; flipmax.lisp : フリップ・イット 最長手数の探索
;;;
;;;                Copyright (C) 2003-2023 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))
    ;; 探索
    (do ()
        ((>= 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)))

初版 2003 年 12 月 10 日
改訂 2023 年 7 月 16 日

変形魔方陣

今回はパズル「変形魔方陣」の解法プログラムを Common Lisp で作ってみましょう。

●問題１

それでは問題です。

[問題１] 変形魔方陣

上図の A から I の場所に 1 から 9 までの数字をひとつずつ配置します。図では、A - B - E - D のように 2 * 2 マスの正方形が 4 つ、大きな正方形 (A - C - I - G) がひとつあります。魔方陣は縦横斜めの合計が等しくなるように数字を配置しますが、今回は上図の式で表すように、正方形の頂点の合計が等しくなるような配置を見つけてください。

出典は『Ｃマガ電脳クラブ第 92 回変形魔方陣』, C MAGAZINE 1998 年 8 月号, ソフトバンクです。Ｃマガ電脳クラブの問題は、2 * 2 マスの数字の合計が等しくなることが条件でしたが、今回は大きな正方形も条件に加えてみました。

解答

●プログラムの作成

プログラムを作る場合、対称解のチェックは面倒だと思われる方もいるでしょう。ところが、下図のように四隅の大小関係を利用すると簡単です。


      図 : 対称解のチェック

魔方陣の場合、回転解が 4 種類あって、鏡像解が 2 種類あります。四隅の大小関係をチェックすることで、これらの対称解を排除することができます。また、早い段階で枝刈りを行うため、盤面の番号と試行順序を工夫します。

盤面を 1 次元配列 B で表すことにします。試行順序を上図のように定義し、配列の添字と対応させます。そうすると、最初に四隅 (0, 1, 2, 3) の数字が選択されますね。ここで対称解のチェックが行われるので、枝刈りの効率は良くなります。また、数字の合計値 N も決めることができるので、あとは 2 * 2 マスの正方形が完成したら、合計値が N と等しいかチェックしていくだけです。

プログラムは次のようになります。配列を使っているので Lisp らしくありませんが、ほかのプログラミング言語に移植するのは簡単でしょう。興味のある方は挑戦してみてください。

リスト : 解法プログラム

;;; 盤面
(defvar *board* (make-array 9))

;;; 解の表示
(defun print-answer ()
  (format t "~D ~D ~D~%~D ~D ~D~%~D ~D ~D~%~%"
          (aref *board* 0) (aref *board* 4) (aref *board* 1)
          (aref *board* 5) (aref *board* 6) (aref *board* 7)
          (aref *board* 2) (aref *board* 8) (aref *board* 3)))

;;; 4 つの数字を足し算する
(defun add-number (a b c d)
  (+ (aref *board* a) (aref *board* b) (aref *board* c) (aref *board* d)))

;;; 枝刈り
(defun checkp (n value)
  (or (and (= n 1) (> (aref *board* 0) (aref *board* 1)))
      (and (= n 2) (> (aref *board* 1) (aref *board* 2)))
      (and (= n 3) (> (aref *board* 0) (aref *board* 3)))
      (and (= n 6) (/= value (add-number 0 4 5 6)))
      (and (= n 7) (/= value (add-number 1 4 6 7)))))

;;; 解法
(defun solve (&optional (n 0) (numbers '(1 2 3 4 5 6 7 8 9)) value)
  (dolist (x numbers)
    (setf (aref *board* n) x)
    ;; 枝刈り
    (unless (checkp n value)
      ;; value のセット
      (if (= n 3)
          (setq value (add-number 0 1 2 3)))
      ;; 解けたか
      (cond ((= n 8)
             (if (= value (add-number 2 5 6 8) (add-number 3 6 7 8))
                 (print-answer)))
            (t (solve (1+ n) (remove x numbers) value))))))

●問題２

次は 8 個の数字を使う魔方陣です。それでは問題です。

[問題２] 変形魔方陣

上図の A から H の場所に 1 から 8 までの数字をひとつずつ配置します。4 辺の合計が等しくなるような配置を見つけてください。なお、合計の値 (N) は 12, 13, 14, 15 の 4 通りの場合があります。

解答

プログラムの作成は簡単です。問題１のプログラムを改造するだけです。特に難しいところはないので、説明は省略いたします。詳細はプログラムリストをお読みくださいませ。

ところで、問題２は数字 { 1, 2, 3, 4, 5, 6, 7, 8 } を使いましたが、数字を奇数 { 1, 3, 5, 7, 9, 11, 13, 15 } にする、または、数字を偶数 { 2, 4, 6, 8, 10, 12, 14, 16 } にするとどうなるでしょうか。実は、問題２の答えがわかると簡単に解くことができます。答えを見る前に、ちょっと考えてみてくださいね。

解答

●問題３

最後は素数を使った変形魔方陣です。

[問題３] 素数の変形魔方陣

上図の A から H の場所に素数 { 3, 5, 7, 11, 13, 17, 19, 23 } をひとつずつ配置します。4 辺の合計が等しくなるような配置を見つけてください。なお、合計の値 (N) も素数になります。

解答

●プログラムリスト

;;;
;;; magic2.lisp : 変形魔方陣の解法プログラム
;;;
;;;               Copyright (C) 2005-2023 Makoto Hiroi
;;;

;;;  盤面
;;;
;;; ０４１
;;; ５  ６  0 < 1 < 2, 0 < 3
;;; ２７３  
;;;
(defvar *board* (make-array 8))

;;; 数字を足し算する
(defun add-number (n1 n2 n3)
  (+ (aref *board* n1) (aref *board* n2) (aref *board* n3)))

;;; 解の表示
(defun print-answer (rest-num)
  (format t "Rest ~A, Sum ~D~%" rest-num (add-number 0 4 1))
  (format t "~2D ~2D ~2D~%~2D    ~2D~%~2D ~2D ~2D~%~%"
          (aref *board* 0) (aref *board* 4) (aref *board* 1)
          (aref *board* 5)                  (aref *board* 6)
          (aref *board* 2) (aref *board* 7) (aref *board* 3)))

;;; 枝刈り
(defun checkp (n value)
  (or (and (= n 1) (> (aref *board* 0) (aref *board* 1)))
      (and (= n 2) (> (aref *board* 1) (aref *board* 2)))
      (and (= n 3) (> (aref *board* 0) (aref *board* 3)))
      (and (= n 5) (/= value (add-number 0 5 2)))
      (and (= n 6) (/= value (add-number 1 6 3)))))

;;; 解法
(defun solve (&optional (n 0) (numbers '(1 2 3 4 5 6 7 8)) value)
  (dolist (x numbers)
    (setf (aref *board* n) x)
    ;; 枝刈り
    (unless (checkp n value)
      ;; value のセット
      (if (= n 4)
          (setq value (add-number 0 1 4)))
      ;; 解けたか
      (cond ((= n 7)
             (if (= value (add-number 2 7 3))
                 (print-answer (remove x numbers))))
            (t (solve (1+ n) (remove x numbers) value))))))