今回も簡単なパズルを 5 問出題します。Scheme で解法プログラムを作成してください。なお、この問題は拙作のページ xyzzy Lisp Programming と Puzzle DE Programming で出題されているものと同じです。M.Hiroi は R5RS + SRFI-1 の範囲でプログラムを作ろうと思っています。他のライブラリを使うと、もっと簡単にプログラムを作ることができるかもしれません。みなさんも Scheme らしいプログラムを考えてみてください。
ある連続した３数 (n, n+1, n+2) を掛け合わせたら、大町数になったという。そのような３数をすべて見つけてほしい。もちろん、負の数は考えない。
出典：『Ｃマガ電脳クラブ』 Ｃマガジン 1998 年 2 月号（ソフトバンク）
パズルの世界では小町数に 0 を加えた数を「大町数」といいます。そして、0 から 9 までの 10 個の数字を 1 個ずつ使った計算を「大町算」といいます。ただし、0123456789 のように最上位の桁に 0 を入れることはできません。
騎士（ナイト）はチェスの駒のひとつで、将棋の桂馬の動きを前後左右にとることができます。次の図を見てください。
┌─┬─┬─┬─┬─┐
│ │●│ │●│ │
├─┼─┼─┼─┼─┤ ┌─┬─┐
│●│ │ │ │●│ │Ｋ│ │
├─┼─┼─┼─┼─┤ ┌─┼─┼─┼─┐
│ │ │Ｋ│ │ │ │ │ │ │ │
├─┼─┼─┼─┼─┤ ├─┼─┼─┼─┤
│●│ │ │ │●│ │ │ │ │ │
├─┼─┼─┼─┼─┤ └─┼─┼─┼─┘
│ │●│ │●│ │ │ │ │
└─┴─┴─┴─┴─┘ └─┴─┘
●：ナイト (K) が動ける位置 問題Ａ
図 : 騎士の周遊
このナイトを動かして、どのマスにもちょうど一回ずつ訪れて出発点に戻る周遊経路を求めるのが問題です。ちなみに、4 行 4 列の盤面には解がありませんが、6 行 6 列、8 行 8 列の盤面には解が存在します。大きな盤面を解くのは大変なので、問題 A の盤面でナイトの周遊経路を求めてください。
三組の夫婦が川を渡ることになりました。ボートには二人しか乗ることができません。どの夫も嫉妬深く、彼自身が一緒にいない限り、ボートでも岸でも妻が他の男といることを許しません。なお、六人ともボートをこぐことができます。この条件で、三組の夫婦が川を渡る最短手順を考えてください。
「嫉妬深い夫の問題」は「川渡りの問題」と呼ばれる古典的なパズルの一種です。このパズルにはたくさんのバリエーションがありますが、その中で 「農夫と山羊と狼とキャベツの問題」 や前回出題した「宣教師と人食い人」という危険な名前のパズルが有名です。
┌──────┬──────┐
│ Ａ │ Ｂ │
│ ┌──┬─┴─┬──┐ │
│ │ │ Ｄ │ │ │
│ │ Ｃ ├─┬─┤ Ｅ │ │
│ │ │ │ │ │ │
│ ├──┤Ｇ│Ｈ├──┤ │
│ │ │ │ │ │ │
│ │ Ｆ ├─┴─┤ Ｉ │ │
│ │ │ Ｊ │ │ │
│ ├──┴─┬─┴──┤ │
│ │ Ｋ │ Ｌ │ │
│ └────┴────┴─┤
│ │
└─────────────┘
図 : 簡単な地図
「地図の配色問題」は、平面上にある隣り合った地域が同じ色にならないように塗り分けるという問題です。1976 年にアッペルとハーケンにより、どんな場合でも 4 色あれば塗り分けできることが証明されました。これを「四色問題」といいます。今回は上図に示す簡単な地図を 4 色で塗り分けてください。
┌───┬─┬─┐ ┌─┬─┬───┐ ┌───┬─┬─┐
│ 電球 │Ｏ│Ｎ│ │Ｎ│Ｏ│ 電球 │ │ 電球 │Ｎ│Ｏ│
├─┬─┼─┼─┤ ├─┼─┼─┬─┤ ├─┬─┼─┼─┤
│Ｏ│Ｆ│Ｆ│ │ │Ｆ│Ｏ│Ｆ│ │ │Ｏ│Ｆ│Ｆ│ │
└─┴─┴─┴─┘ └─┴─┴─┴─┘ └─┴─┴─┴─┘
問題Ａ 問題Ｂ ＧＯＡＬ
図：NO-OFF
問題 A, B から GOAL までの最短手順を求めてください。
スライドパズル NO-OFF は、問題 A の "ON-OFF" を GOAL のように "NO-OFF" にチェンジするパズルです。NO-OFF は芦ヶ原伸之氏が考案されたパズルで、C MAGAZINE 1991 年 1 月号の「Ｃマガ電脳クラブ」でも出題されています。問題 B は GOAL からの最長手数の局面のひとつです。このパズルは局面の総数が少ないにもかかわらず、手数がけっこうかかる面白いパズルです。
それではプログラムを作りましょう。最初に整数 n の範囲を絞り込みます。大町数の最大値は 9876543210 で最小値は 1023456789 ですから、n の値は次の範囲内になります。
gosh> (expt 1023456789 1/3) 1007.758578449832 gosh> (* 1006 1007 1008) 1021146336 gosh> (expt 9876543210 1/3) 2145.5319657992272 gosh> (* 2145 2146 2147) 9883005990
(expt x y) は x の y 乗を返します。これらの計算結果から n は 1007 以上 2144 以下であることがわかります。n の範囲がぐっと狭くなりましたね。これならば、あとは単純に計算して大町数になるかチェックすればいいでしょう。プログラムは次のようになります。
リスト : パズル「３数で大町どうさま」の解法
; 数値を一桁ずつ分解する
(define (split-digit n a)
(if (zero? n)
a
(split-digit (quotient n 10) (cons (modulo n 10) a))))
; 10 個の要素 (数字) がすべて異なること
(define (check? ls)
(cond ((null? ls) #t)
((member (car ls) (cdr ls)) #f)
(else (check? (cdr ls)))))
; 解法
(define (solve-1)
(let loop ((n 1007))
(cond ((<= n 2144)
(if (check? (split-digit (* n (+ n 1) (+ n 2)) '()))
(format #t "~D * ~D * ~D = ~D\n"
n (+ n 1) (+ n 2) (* n (+ n 1) (+ n 2))))
(loop (+ n 1))))))
プログラムは単純な生成検定法です。関数 solve-1 で 1007 から 2144 までの数値を生成します。関数 split-digit は数値を一桁ずつ分解してリストに格納します。3 つの数値を掛け算すると 10 桁の数値になるので、大町数であれば 10 個の数字がちょうどひとつずつあるはずです。したがって、数字が重複していないことを述語 check? で確認すればいいわけです。大町数であれば format で解を出力します。
これでプログラムは完成です。さっそく実行してみましょう。
gosh> (solve-1) 1267 * 1268 * 1269 = 2038719564 1332 * 1333 * 1334 = 2368591704 #<undef>
2 通りの解を見つけることができました。
それではプログラムを作りましょう。この問題は盤面が小さいので、単純な深さ優先探索で簡単に解くことができます。下図に示すように、盤面のマスに番号をつけます。
┌─┬─┐ ┌─┬─┐
│Ｋ│ │ │０│１│
┌─┼─┼─┼─┐ ┌─┼─┼─┼─┐
│ │ │ │ │ │２│３│４│５│
├─┼─┼─┼─┤ ├─┼─┼─┼─┤
│ │ │ │ │ │６│７│８│９│
└─┼─┼─┼─┘ └─┼─┼─┼─┘
│ │ │ │10│11│
└─┴─┘ └─┴─┘
盤面 番号
図 : 盤面と番号の関係
あとは隣接リストを定義して、深さ優先探索で周遊経路を探索するだけです。プログラムは次のようになります。
リスト : 「騎士の周遊」の解法
; 隣接リスト
(define *adjacent*
#((5 6 8) ; 0
(2 7 9) ; 1
(1 8 10) ; 2
(9 11) ; 3
(6 10) ; 4
(0 7 11) ; 5
(0 4 11) ; 6
(1 5) ; 7
(0 2) ; 8
(1 3 10) ; 9
(2 4 9) ; 10
(3 5 6))) ; 11
; 単純な深さ優先探索
(define (knight-tour n goal path)
(if (= n 12)
(if (member goal (vector-ref *adjacent* (car path)))
(begin (display (cons goal path)) (newline)))
(for-each
(lambda (x)
(if (not (member x path))
(knight-tour (+ n 1) goal (cons x path))))
(vector-ref *adjacent* (car path)))))
;
(define (solve-2) (knight-tour 1 0 '(0)))
隣接リストはベクタ *adjacent* に定義します。要素はリストであることに注意してください。関数 knight-tour は深さ優先探索で騎士の周遊経路を求めます。引数 n は訪れたマスの個数、goal はゴール地点（出発点）、path は経路を表します。周遊経路を求めるので出発点はどこでもいいのですが、今回は 0 を出発点としてます。
全部のマスを 1 回ずつ訪れると n の値は 12 になります。最後のマスから出発点 (goal) に戻ることができれば周遊経路になります。これは最後のマスの隣接リストに goal が含まれているかチェックすればいいですね。そうであれば、周遊経路になるので display で path を表示します。n が 12 より小さい場合は、深さ優先で騎士を進めていきます。
それでは、実行してみましょう。
gosh> (solve-2) (0 8 2 10 4 6 11 3 9 1 7 5 0) (0 8 2 1 7 5 11 3 9 10 4 6 0) (0 6 4 10 9 3 11 5 7 1 2 8 0) (0 5 7 1 9 3 11 6 4 10 2 8 0) #<undef>
4 通りの周遊経路が表示されましたが、逆回りの経路があるので、実際の経路は次の 2 通りになります。
┌─┬─┐ ┌─┬─┐
│０│３│ │０│９│
┌─┼─┼─┼─┐ ┌─┼─┼─┼─┐
│10│５│８│１│ │10│５│２│７│
├─┼─┼─┼─┤ ├─┼─┼─┼─┤
│７│２│11│４│ │１│８│11│４│
└─┼─┼─┼─┘ └─┼─┼─┼─┘
│９│６│ │３│６│
└─┴─┘ └─┴─┘
図 : 周遊経路
「騎士の周遊」は、拙作のページ Puzzle DE Programming の 「騎士の巡歴 (Knight's Tour)」 でも取り上げています。興味のある方はお読みくださいませ。
それではプログラムを作ります。今回は左岸から右岸へ渡ることにしましょう。まず最初に、夫婦と岸の状態を表すデータ構造を決めます。いろいろな方法が考えられますが、今回は 3 組の夫婦をシンボル Ha, Wa, Hb, Wb, Hc, Wc で、岸の状態をリストで表すことにします。H で始まるシンボルが夫、W で始まるシンボルが妻を表します。
そして、ボートの位置 (left or right)、左岸の状態、右岸の状態をリストに格納します。したがって、最初の局面は (left (Ha Hb Hc Wa Wb Wc) ())、ゴールの局面は (right () (Ha Hb Hc Wa Wb Wc)) と表すことができます。
岸の状態はシンボルの集まりなので、リストを「集合 (set) 」として扱うと操作が簡単になります。集合については拙作のページ 集合、グラフ、経路の探索 をお読みください。SRFI-1 に用意されている主なリストの集合演算を表に示します。
| 関数名 | 機能 |
|---|---|
| lset-union = list1 list2 | list1 と list2 の和を求める |
| lset-intersection = list1 list2 | list1 と list2 の積を求める |
| lset-difference = list1 list2 | list2 に現れない list1 の要素をリストにして返す |
| lset-xor = list1 list2 | list1 と list2 の両方にちょうど 1 つだけ現れる要素をリストにして返す |
| lset<= = list1 list2 | list1 の要素がすべて list2 に含まれていれば真を返す (部分集合の判定) |
| lset= = list1 list2 | list1 の要素がすべて list2 に含まれ、かつ list2 の要素がすべて list1 に含まれていれば真を返す (集合同値の判定) |
引数 = は要素の同値を判定する述語を指定します。今回はシンボルが要素なので eq? を指定すればいいでしょう。
まずはデータと補助関数を定義します。次のリストを見てください。
リスト : データと補助関数の定義 ; 夫婦 (define *pair* '((Wa . Ha) (Wb . Hb) (Wc . Hc))) ; 女性 (define *female* '(Wa Wb Wc)) ; 男性 (define *male* '(Ha Hb Hc)) ; x は女性か (define (female? x) (member x *female*)) ; x は男性か (define (male? x) (member x *male*)) ; x の夫を求める (define (get-male x) (cdr (assoc x *pair*))) ; 男性が含まれているか (define (check-male? ls) (pair? (lset-intersection eq? ls *male*))) ; アクセス関数 (define (get-boat state) (first state)) (define (get-left state) (second state)) (define (get-right state) (third state))
夫婦、男性、女性を表すデータを *pair*, *male*, *female* に定義します。述語 female? は引数 x が女性であれば真を返します。male? は引数 x が男性ならば真を返します。関数 get-male は女性 x の夫を求めます。*pair* は連想リストなので、assoc で x を探索して、その cdr の値を返すだけです。述語 check-male? は引数 ls に男性が含まれている場合は真を返します。これは ls と *male* の積を求めて pair? でチェックするだけです。
次はボートや岸の状態が安全か確認する述語 safe? を作ります。
リスト : 安全確認
(define (safe? ls)
(if (not (check-male? ls))
#t ; 男性がいない場合は安全
(every (lambda (x)
(or (male? x) (member (get-male x) ls)))
ls)))
引数 ls はボートまたは岸の状態を表すリストです。ls に男性がいない場合は安全です。check-male? が偽を返す場合は #t を返します。次に、every で ls の要素 x をチェックします。x が男性であれば問題ありません。女性の場合は夫がいるか確認します。get-male で夫を求め、一緒にいることを member で確かめます。
次はボートに乗る組み合わせを求める関数 boat-combinations を作ります。
リスト : ボートに乗る組み合わせを作る
; 組み合わせの生成
(define (combinations-list n ls)
(define (comb n ls a b)
(cond ((zero? n)
(cons (reverse a) b))
((= (length ls) n)
(cons (append (reverse a) ls) b))
(else
(comb (- n 1)
(cdr ls)
(cons (car ls) a)
(comb n (cdr ls) a b)))))
(if (> n (length ls))
'() ; 修正
(comb n ls '() '())))
; ボートに乗る組み合わせを作る
(define (boat-combinations ls)
(filter safe?
(append (combinations-list 1 ls)
(combinations-list 2 ls))))
combinations-list はリスト ls から n 個を取り出す組み合わせを求めます。これは拙作のページ 順列と組み合わせ で作成したプログラムとほぼ同じですが、ls の長さが n よりも短い場合は空リストを返すように修正しています。
boat-combinations は引数 ls からボートに乗り込む組み合わせを作ります。ls から 1 人選ぶ組み合わせと 2 人選ぶ組み合わせを求めて append で連結します。そして、filter で安全な状態のみを取り出して返します。
次はボートを動かして新しい局面を生成する関数 move-boat を作ります
リスト : ボートを動かして新しい局面を生成する
; 新しい局面を作る
(define (make-new-state state xs)
(if (eq? (get-boat state) 'left)
(list 'right
(lset-xor eq? (get-left state) xs)
(lset-union eq? (get-right state) xs))
(list 'left
(lset-union eq? (get-left state) xs)
(lset-xor eq? (get-right state) xs))))
; ボートを動かす
(define (move-boat state)
(filter (lambda (new-state)
(every safe? (cdr new-state)))
(map (lambda (xs) (make-new-state state xs))
(boat-combinations
(if (eq? (get-boat state) 'left)
(get-left state)
(get-right state))))))
関数 make-new-state は局面 state から新しい局面を生成します。xs はボートに乗る人を格納したリストです。ボートが左岸にある場合、ボートを right に、左岸から xs を削除し、右岸に xs を追加します。この処理は lset-xor と lset-union を使うと簡単です。ボートが右岸にある場合は、ボートを left に、左岸に xs を追加して、右岸から xs を削除します。
関数 move-boat は boat-combinations でボートに乗る人の組み合わせを求め、その要素に map で make-new-state を適用して新しい局面を作ります。そして、filter で安全な局面だけを取り出します。filter に渡すラムダ式で、左岸と右岸が安全かチェックしています。この処理は every を使うと簡単です。
あとは、幅優先探索か反復深化を使えば、最短手順を求めることができます。説明は割愛いたしますので、詳細は プログラムリスト３ をお読みください。
それでは実行してみましょう。
gosh> (solve-30 '(left (Ha Hb Hc Wa Wb Wc) ()) '(right () (Ha Hb Hc Wa Wb Wc))) (left (Ha Hb Hc Wa Wb Wc) ()) (right (Hb Hc Wb Wc) (Ha Wa)) (left (Ha Hb Hc Wb Wc) (Wa)) (right (Ha Hb Hc) (Wc Wb Wa)) (left (Wc Ha Hb Hc) (Wb Wa)) (right (Wc Hc) (Hb Ha Wb Wa)) (left (Wb Hb Wc Hc) (Ha Wa)) (right (Wb Wc) (Hc Hb Ha Wa)) (left (Wa Wb Wc) (Hc Hb Ha)) (right (Wc) (Wb Wa Hc Hb Ha)) (left (Wb Wc) (Wa Hc Hb Ha)) (right () (Wc Wb Wa Hc Hb Ha)) #<undef>
11 手で解くことができました。なお、Puzzle DE Programming では 「農夫と山羊と狼とキャベツの問題」 を取り上げています。興味のある方は参考にしてください。
;
; 嫉妬深い夫の問題
;
; Copyright (C) 2009 Makoto Hiroi
;
; データと補助関数の定義
(define *pair* '((Wa . Ha) (Wb . Hb) (Wc . Hc)))
(define *female* '(Wa Wb Wc))
(define *male* '(Ha Hb Hc))
(define (female? x) (member x *female*))
(define (male? x) (member x *male*))
(define (get-male x) (cdr (assoc x *pair*)))
; 男性がいるか
(define (check-male? state)
(pair? (lset-intersection eq? state *male*)))
; アクセス関数
(define (get-boat state) (first state))
(define (get-left state) (second state))
(define (get-right state) (third state))
; 安全確認
(define (safe? ls)
(if (not (check-male? ls))
#t ; 男性がいない場合は安全
(every (lambda (x)
(or (male? x) (member (get-male x) ls)))
ls)))
; 組み合わせの生成
(define (combinations-list n ls)
(define (comb n ls a b)
(cond ((zero? n)
(cons (reverse a) b))
((= (length ls) n)
(cons (append (reverse a) ls) b))
(else
(comb (- n 1)
(cdr ls)
(cons (car ls) a)
(comb n (cdr ls) a b)))))
(if (> n (length ls))
'()
(comb n ls '() '())))
; ボートに乗る組み合わせを作る
(define (boat-combinations state)
(filter safe?
(append (combinations-list 1 state)
(combinations-list 2 state))))
; 新しい局面を作る
(define (make-new-state state xs)
(if (eq? (get-boat state) 'left)
(list 'right
(lset-xor eq? (get-left state) xs)
(lset-union eq? (get-right state) xs))
(list 'left
(lset-union eq? (get-left state) xs)
(lset-xor eq? (get-right state) xs))))
; ボートを動かす
(define (move-boat state)
(filter (lambda (new-state)
(every safe? (cdr new-state)))
(map (lambda (xs) (make-new-state state xs))
(boat-combinations
(if (eq? (get-boat state) 'left)
(get-left state)
(get-right state))))))
; 同一局面のチェック
(define (equal-state? s1 s2)
(and (eq? (car s1) (car s2))
(lset= eq? (get-left s1) (get-left s2))
(lset= eq? (get-right s1) (get-right s2))))
; 幅優先探索
(define (solve-30 start goal)
; キュー
(define que '())
(define (enqueue x)
(set! que (append que (list x))))
(define (dequeue)
(begin0 (car que) (set! que (cdr que))))
;
(define (print-answer move)
(for-each (lambda (x) (display x) (newline))
move))
;
(enqueue (list start))
(let loop ()
(let ((move (dequeue)))
(cond ((equal-state? (car move) goal)
(print-answer (reverse move))
(newline))
(else
(for-each
(lambda (state)
(if (not (find (lambda (x) (equal-state? x state)) move))
(enqueue (cons state move))))
(move-boat (car move)))
(loop))))))
; 反復深化
(define (solve-31 start goal)
(define (print-answer move)
(for-each (lambda (x) (display x) (newline))
move))
(define (solve-id limit n move cont)
(if (= n limit)
(if (equal-state? (car move) goal)
(begin (print-answer (reverse move))
(cont #t)))
(for-each
(lambda (state)
(if (or (null? (cdr move))
(not (equal-state? (second move) state)))
(solve-id limit (+ n 1) (cons state move) cont)))
(move-boat (car move)))))
(call/cc
(lambda (found)
(for-each
(lambda (x)
(format #t "---- ~D ----\n" x)
(solve-id x 0 (list start) found))
(iota 20 1)))))
それではプログラムを作りましょう。今回の地図の配色は、単純な深さ優先探索で簡単に解くことができます。順番に地域の色を決めていきますが、このときに隣接している地域と異なる色を選びます。もし、色を選ぶことができなければ、バックトラックして前の地域に戻り違う色を選びます。
地域の色は連想リストで管理することにします。この場合、地域の色を求める関数 get-color と地域の色を更新する関数 set-color! は次のようになります。
リスト : 色のアクセス関数 ; region の色を求める (define (get-color region ls) (cdr (assoc region ls))) ; region の色を color にセットする (define (set-color! region color ls) (set-cdr! (assoc region ls) color))
引数 ls が連想リストです。get-color は assoc で ls から region を探索し、その cdr を返します。set-color! は assoc で ls から region を探索し、その CDR 部を set-cdr! で color に書き換えます。
次に、隣り合った地域で同じ色が使われていないかチェックする述語 same-color? を作ります。次のリストを見てください。
リスト : 同じ色が使われていないか確認する
; 隣接リスト
(define *adjacent-map*
'((A B C D F K L)
(B A D E I L)
(C A D F G)
(D A B C E G H)
(E B D H I)
(F A C G J K)
(G C D H F J)
(H D E G I J)
(I B E H J L)
(J F G H I K L)
(K A F J L)
(L A B I J K)))
; 同じ色が使われていないか確認する
(define (same-color? region color ls)
(find (lambda (x) (eq? (get-color x ls) color))
(cdr (assoc region *adjacent-map*))))
*adjacent-map* は隣接リストです。連想リストを使って定義していることに注意してください。same-color? は簡単で、 assoc で region の隣接リストを求め、find で color と同じ色が使われている地域を探索します。色はシンボル red, blue, green, yellow で表します。見つからない場合は #f を返します。
あとは単純な深さ優先探索で解くことができます。プログラムは次のようになります。
リスト : 地図の配色問題
(define (solve-4)
(define *region* '(A B C D E F G H I J K L))
(define *region-color*
(map (lambda (x) (cons x #f)) *region*))
;
(define (print-answer)
(for-each (lambda (x) (display x) (newline))
*region-color*))
;
(define (solve rs break)
(cond ((null? rs)
(print-answer)
(break #t))
(else
(for-each
(lambda (color)
(set-color! (car rs) color *region-color*)
(if (not (same-color? (car rs) color *region-color*))
(solve (cdr rs) break))
(set-color! (car rs) #f *region-color*))
'(red blue green yellow)))))
(call/cc
(lambda (break) (solve *region* break))))
*region* は地域を表すリスト、*region-color* が地域と色を表す連想リストです。地域の色は #f で初期化します。solve は深さ優先探索で地域の色を順番に決めていきます。same-color? で隣り合った地域の色を確認し、同じ色がなければ solve を再帰呼び出しします。同じ色が使われている場合は異なる色を選択します。解を一つ見つけたら print-answer で解を表示して処理を終了します。
それでは実行してみましょう。
gosh> (solve-4) (A . red) (B . blue) (C . blue) (D . green) (E . red) (F . green) (G . yellow) (H . blue) (I . green) (J . red) (K . blue) (L . yellow) #t
確かに 4 色で解くことができました。
それではプログラムを作りましょう。今回は盤面をベクタで表すことにします。盤面を表すデータ構造を下図に示します。
┌─┬─┬─┬─┐ ┌─┬─┬─┬─┐
│０│１│２│３│ │Ｌ│Ｌ│Ｎ│Ｏ│
├─┼─┼─┼─┤ ├─┼─┼─┼─┤
│４│５│６│７│ │Ｏ│Ｆ│Ｆ│Ｓ│
└─┴─┴─┴─┘ └─┴─┴─┴─┘
盤面と添字の対応 駒の種類
図 : 盤面のデータ構造
駒の種類はシンボルで表します。電球は 2 つの駒 L で表し、2 つの駒を連結して動かすことにします。電球を動かすことができるのは左右方向だけで、下に動かすことはできません。このため、局面の総数は 540 通りしかありません。
電球(3 通り) * 空き場所(6 通り) * N (5 通り) * O (4C2 = 6 通り) = 540 通り
アルゴリズムは単純な幅優先探索で十分でしょう。
最初に隣接リストとアクセス関数を定義します。
リスト : 隣接リストとアクセス関数
; 隣接リスト
(define *adjacent-slide*
#((1 4) ; 0
(0 2 5) ; 1
(1 3 6) ; 2
(2 7) ; 3
(0 5) ; 4
(1 4 6) ; 5
(2 5 7) ; 6
(3 6))) ; 7
; 局面 : (prev-state space board)
; アクセス関数
(define (get-prev-state state) (first state))
(define (get-space state) (second state))
(define (get-board state) (third state))
局面はリストで表します。prev-state は 1 手前の局面、space は空き場所の位置、board は盤面を表します。
次は、駒を動かして新しい局面を生成する関数 move-piece を作ります。
リスト : 駒を動かして新しい局面を作る
; 新しい盤面を作る
(define (make-new-board board s x)
(let ((new-board (vector-copy board)))
(vector-set! new-board s (vector-ref new-board x))
(vector-set! new-board x 'S)
new-board))
; 電球
(define (light? board x) (eq? (vector-ref board x) 'L))
; 駒を動かす
(define (move-piece state x)
(let ((board (get-board state))
(s (get-space state)))
(cond ((light? (get-board state) x)
(cond ((< s 2)
; 左へ動かす
(list state (+ s 2) (make-new-board board s (+ s 2))))
((< s 4)
; 右へ動かす
(list state (- s 2) (make-new-board board s (- s 2))))
(else #f)))
(else
; 普通に動かす
(list state x (make-new-board board s x))))))
関数 make-new-board は x の位置にある駒を空き場所 s の位置に動かして新しい盤面 new-board を作ります。vector-copy はベクタをコピーする関数です。SRFI-43 に定義されている関数ですが、Gauche では標準で用意されています。R5RS + SRFI-1 の範囲外になりますが、ご容赦くださいませ。
move-piece は x の位置にある駒を空き場所に動かして新しい局面を作ります。x の位置にある駒が電球の場合、空き場所 s が 0, 1 ならば電球を左へ動かします。2, 3 ならば右へ動かします。それ以外の場合は動かすことができないので #f を返します。電球でなければ、x の駒を s に動かします。
あとは単純な幅優先探索なので、説明は割愛いたします。詳細は プログラムリスト５ をお読みください。
それでは解答を示します。
(0) (1) (2) (3) (4) (5) (6) (7)
L L O N L L O S L L S O S L L O O L L O O L L O O L L O O L L O
O F F S O F F N O F F N O F F N S F F N F S F N F F S N F F N S
(8) (9) (10) (11) (12) (13) (14) (15)
O L L S O S L L S O L L F O L L F O L L F S L L F L L S F L L O
F F N O F F N O F F N O S F N O F S N O F O N O F O N O F O N S
(16) (17) (18) (19) (20) (21) (22) (23)
F L L O F L L O F L L O S L L O L L S O L L O S L L O N L L O N
F O S N F S O N S F O N F F O N F F O N F F O N F F O S F F S O
(24) (25) (26) (27) (28) (29) (30) (31)
L L S N S L L N F L L N F L L N F L L N F L L N F L L S F S L L
F F O O F F O O S F O O F S O O F O S O F O O S F O O N F O O N
(32) (33) (34) (35) (36) (37) (38) (39)
F O L L F O L L S O L L O S L L O L L S O L L N O L L N O L L N
F S O N S F O N F F O N F F O N F F O N F F O S F F S O F S F O
(40) (41) (42) (43) (44)
O L L N S L L N L L S N L L N S L L N O
S F F O O F F O O F F O O F F O O F F S
図 : 問題Ａの解答 (44 手)
(0) (1) (2) (3) (4) (5) (6) (7)
N O L L N O L L N O L L N S L L N L L S N L L F N L L F N L L F
F O F S F O S F F S O F F O O F F O O F F O O S F O S O F S O O
(8) (9) (10) (11) (12) (13) (14) (15)
N L L F S L L F L L S F L L F S L L F O L L F O L L S O S L L O
S F O O N F O O N F O O N F O O N F O S N F S O N F F O N F F O
(16) (17) (18) (19) (20) (21) (22) (23)
N L L O N L L O N L L O N L L O N L L S N S L L S N L L F N L L
S F F O F S F O F F S O F F O S F F O O F F O O F F O O S F O O
(24) (25) (26) (27) (28) (29) (30) (31)
F N L L F S L L F L L S F L L O F L L O F L L O F L L O S L L O
F S O O F N O O F N O O F N O S F N S O F S N O S F N O F F N O
(32) (33) (34) (35) (36) (37) (38) (39)
L L S O L L N O L L N O L L N S L L S N S L L N F L L N F L L N
F F N O F F S O F F O S F F O O F F O O F F O O S F O O F S O O
(40) (41) (42) (43) (44) (45) (46) (47)
F L L N F L L N F L L S F S L L F O L L F O L L S O L L O S L L
F O S O F O O S F O O N F O O N F S O N S F O N F F O N F F O N
(48) (49) (50) (51) (52) (53) (54) (55)
O L L S O L L N O L L N O L L N O L L N S L L N L L S N L L N S
F F O N F F O S F F S O F S F O S F F O O F F O O F F O O F F O
(56)
L L N O
O F F S
図 : 問題Ｂの解答 (56 手)
ちなみに、GOAL までの最長手数は 56 手で、局面は全部で 3 通りあります。問題 B はその中の 1 つです。
┌─┬─┬───┐ ┌─┬─┬───┐ ┌─┬─┬───┐
│Ｆ│Ｎ│ 電球 │ │Ｎ│Ｏ│ 電球 │ │Ｏ│Ｆ│ 電球 │
├─┼─┼─┬─┤ ├─┼─┼─┬─┤ ├─┼─┼─┬─┤
│Ｏ│Ｏ│Ｆ│ │ │Ｆ│Ｏ│Ｆ│ │ │Ｎ│Ｏ│ │Ｆ│
└─┴─┴─┴─┘ └─┴─┴─┴─┘ └─┴─┴─┴─┘
図：最長手数の局面
;
; スライドパズル NO-OFF
;
; Copyright (C) 2009 Makoto Hiroi
;
(use srfi-1)
; 隣接リスト
(define *adjacent-slide*
#((1 4) ; 0
(0 2 5) ; 1
(1 3 6) ; 2
(2 7) ; 3
(0 5) ; 4
(1 4 6) ; 5
(2 5 7) ; 6
(3 6))) ; 7
; 局面 : (prev-state space board)
; アクセス関数
(define (get-prev-state state) (first state))
(define (get-space state) (second state))
(define (get-board state) (third state))
; 新しい盤面を作る
(define (make-new-board board s x)
(let ((new-board (vector-copy board)))
(vector-set! new-board s (vector-ref new-board x))
(vector-set! new-board x 'S)
new-board))
; 電球
(define (light? board x) (eq? (vector-ref board x) 'L))
; 駒を動かす
(define (move-piece state x)
(let ((board (get-board state))
(s (get-space state)))
(cond ((light? (get-board state) x)
(cond ((< s 2)
; 左へ動かす
(list state (+ s 2) (make-new-board board s (+ s 2))))
((< s 4)
; 右へ動かす
(list state (- s 2) (make-new-board board s (- s 2))))
(else #f)))
(else
; 普通に動かす
(list state x (make-new-board board s x))))))
;
(define (solve-5 start)
; ゴール
(define goal #(L L N O O F F S))
; キュー
(define que (make-vector 540))
(define wp 0)
(define rp 0)
(define (enqueue state)
(vector-set! que wp state)
(set! wp (+ wp 1)))
(define (dequeue)
(begin0
(vector-ref que rp)
(set! rp (+ rp 1))))
; 同じ盤面があるか
(define (same-board? board)
(let loop ((i 0))
(cond ((<= wp i) #f)
((equal? (get-board (vector-ref que i)) board) #t)
(else (loop (+ i 1))))))
; 空き場所の位置を求める
(define (position-space board)
(let loop ((i 0))
(cond ((<= 8 i) #f)
((eq? (vector-ref board i) 'S) i)
(else (loop (+ i 1))))))
; 手順を表示
(define (print-answer state)
(if (pair? (get-prev-state state))
(print-answer (get-prev-state state)))
(let loop ((i 0))
(cond ((< i 8)
(display (vector-ref (get-board state) i))
(display " ")
(if (= i 3) (newline))
(loop (+ i 1)))
(else (newline) (newline)))))
;
(enqueue (list '() (position-space start) start))
(let loop ()
(let ((state (dequeue)))
(cond ((equal? (get-board state) goal)
(print-answer state))
(else
(for-each
(lambda (x)
(let ((new-state (move-piece state x)))
(if (and new-state
(not (same-board? (get-board new-state))))
(enqueue new-state))))
(vector-ref *adjacent-slide* (get-space state)))
(loop))))))
(define (solve-51) (solve-5 #(L L O N O F F S)))
(define (solve-52) (solve-5 #(N O L L F O F S)))