パズルに挑戦 (2)
今回も簡単なパズルを 5 問出題します。Scheme で解法プログラムを作成してください。M.Hiroi は R7RS-samll + 自作ライブラリ の範囲でプログラムを作ろうと思っています。他のライブラリを使うと、もっと簡単にプログラムを作ることができるかもしれません。みなさんも Scheme らしいプログラムを考えてみてください。
●大町算
ある連続した３数 (n, n+1, n+2) を掛け合わせたら、大町数になったという。そのような３数をすべて見つけてほしい。もちろん、負の数は考えない。
出典：『Ｃマガ電脳クラブ』 Ｃマガジン 1998 年 2 月号（ソフトバンク）
パズルの世界では小町数に 0 を加えた数を「大町数」といいます。そして、0 から 9 までの 10 個の数字を 1 個ずつ使った計算を「大町算」といいます。ただし、0123456789 のように最上位の桁に 0 を入れることはできません。
●騎士の周遊
騎士（ナイト）はチェスの駒のひとつで、将棋の桂馬の動きを前後左右にとることができます。次の図を見てください。
このナイトを動かして、どのマスにもちょうど一回ずつ訪れて出発点に戻る周遊経路を求めるのが問題です。ちなみに、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[r7rs.user]> (expt 1023456789 1/3) 1007.758578449832 gosh[r7rs.user]> (* 1006 1007 1008) 1021146336 gosh[r7rs.user]> (expt 9876543210 1/3) 2145.5319657992272 gosh[r7rs.user]> (* 2145 2146 2147) 9883005990
(expt x y) は x の y 乗を返します。これらの計算結果から n は 1007 以上 2144 以下であることがわかります。n の範囲がぐっと狭くなりましたね。これならば、あとは単純に計算して大町数になるかチェックすればいいでしょう。プログラムは次のようになります。
;;;
;;; oomachi.scm : 三数で大町どうさま
;;;
;;; Copyright (C) 2009-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write))
;;; 数値を一桁ずつ分解する
(define (split-digit n)
(let loop ((n n) (a '()))
(if (zero? n)
a
(loop (quotient n 10) (cons (modulo n 10) a)))))
;;; 10 個の要素 (数字) がすべて異なること
(define (duplicates? pred ls)
(cond
((null? ls) #t)
((member (car ls) (cdr ls) pred) #f)
(else
(duplicates? pred (cdr ls)))))
;;; 解法
(define (solver)
(do ((n 1007 (+ n 1)))
((> n 2144))
(when
(duplicates? eqv? (split-digit (* n (+ n 1) (+ n 2))))
(display n) (display " + ") (display (+ n 1)) (display " + ")
(display (+ n 2)) (display " = ") (display (* n (+ n 1) (+ n 2)))
(newline))))
;;; 実行
(solver)
プログラムは単純な生成検定法です。関数 solver で 1007 から 2144 までの数値を生成します。関数 split-digit は数値を一桁ずつ分解してリストに格納します。3 つの数値を掛け算すると 10 桁の数値になるので、大町数であれば 10 個の数字がちょうどひとつずつあるはずです。したがって、数字が重複していないことを述語 duplicates? で確認すればいいわけです。大町数であれば display で解を出力します。
これでプログラムは完成です。さっそく実行してみましょう。
$ gosh oomachi.scm 1267 + 1268 + 1269 = 2038719564 1332 + 1333 + 1334 = 2368591704
2 通りの解を見つけることができました。
●問題２「騎士の周遊」の解答
それではプログラムを作りましょう。この問題は盤面が小さいので、単純な深さ優先探索で簡単に解くことができます。下図に示すように、盤面のマスに番号をつけます。
あとは隣接リストを定義して、深さ優先探索で周遊経路を探索するだけです。プログラムは次のようになります。
;;;
;;; knight.scm : 騎士の周遊
;;;
;;; Copyright (C) 2009-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write))
;;; 隣接リスト
(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)
(when
(member goal (vector-ref *adjacent* (car path)))
(display (cons goal path)) (newline))
(for-each
(lambda (x)
(unless
(member x path)
(knight-tour (+ n 1) goal (cons x path))))
(vector-ref *adjacent* (car path)))))
;;; 実行
(knight-tour 1 0 '(0))
隣接リストはベクタ *adjacent* に定義します。要素はリストであることに注意してください。関数 knight-tour は深さ優先探索で騎士の周遊経路を求めます。引数 n は訪れたマスの個数、goal はゴール地点（出発点）、path は経路を表します。周遊経路を求めるので出発点はどこでもいいのですが、今回は 0 を出発点としてます。
全部のマスを 1 回ずつ訪れると n の値は 12 になります。最後のマスから出発点 (goal) に戻ることができれば周遊経路になります。これは最後のマスの隣接リストに goal が含まれているかチェックすればいいですね。そうであれば、周遊経路になるので display で path を表示します。n が 12 より小さい場合は、深さ優先で騎士を進めていきます。
それでは、実行してみましょう。
$ gosh knight.scm (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)
4 通りの周遊経路が表示されましたが、逆回りの経路があるので、実際の経路は次の 2 通りになります。
「騎士の周遊」は、拙作のページ Puzzle DE Programming の 「騎士の巡歴 (Knight's Tour)」 でも取り上げています。興味のある方はお読みくださいませ。
●問題３「嫉妬深い夫の問題」の解答
それではプログラムを作ります。今回は左岸から右岸へ渡ることにしましょう。まず最初に、夫婦と岸の状態を表すデータ構造を決めます。いろいろな方法が考えられますが、今回は 3 組の夫婦をシンボル Ha, Wa, Hb, Wb, Hc, Wc で、岸の状態をリストで表すことにします。H で始まるシンボルが夫、W で始まるシンボルが妻を表します。
そして、ボートの位置 (left or right)、左岸の状態、右岸の状態をレコード型 State に格納します。
リスト : 局面の定義 (define-record-type State (make-state boat left right) state? (boat get-boat) (left get-left) (right get-right))
したがって、最初の局面は (make-state 'left '(Ha Hb Hc Wa Wb Wc) '())、ゴールの局面は (make-state 'right '() '(Ha Hb Hc Wa Wb Wc)) となります。
岸の状態はシンボルの集まりなので、リストを「集合 (set)」として扱うと操作が簡単になります。今回は拙作のページ 集合としてのリスト で作成したライブラリ lset.scm を使うことにします。詳細は プログラムリスト をお読みください。
まずはデータと補助関数を定義します。次のリストを見てください。
リスト : データと補助関数の定義 (define *pair* '((Wa . Ha) (Wb . Hb) (Wc . Hc))) (define *male* '(Ha Hb Hc)) (define (male? x) (member x *male*)) (define (get-male x) (cdr (assoc x *pair*)))
夫婦、男性を表すデータを *pair*, *male* に定義します。述語 male? は引数 x が男性ならば真を返します。関数 get-male は女性 x の夫を求めます。*pair* は連想リストなので、assoc で x を探索して、その cdr の値を返すだけです。
次は岸の状態が安全か確認する述語 safe? を作ります。
リスト : 安全確認
(define (safe? ls)
(if (null? (intersection eq? ls *male*))
#t
(every (lambda (x)
(or (male? x) (member (get-male x) ls)))
ls)))
引数 ls は岸の状態を表すリストです。ls に男性がいない場合は安全です。次に、every で ls の要素 x をチェックします。x が男性であれば問題ありません。女性の場合は夫がいるか確認します。get-male で夫を求め、一緒にいることを member で確かめます。
次はボートに乗る組み合わを求める関数 get-riders を作ります。
リスト : ボートに乗る組み合わせを作る
(define riders-list
'((Ha) (Hb) (Hc)
(Wa) (Wb) (Wc)
(Ha Hb) (Ha Hc) (Hb Hc)
(Wa Wb) (Wa Wc) (Wb Wc)
(Ha Wa) (Hb Wb) (Hc Wc)))
(define (get-riders st)
(let ((ys (if (eq? (get-boat st) 'left) (get-left st) (get-right st))))
(filter (lambda (xs) (subset? eq? xs ys)) riders-list)))
大域変数 riders-list にボートに乗ることができる人の組み合わせをセットします。そして、関数 get-riders で実際にボートに乗る人たちを求めます。これは高階関数 filter を使うと簡単です。riders-list からボートに乗る人たちを xs に取り出し、それが岸にいる人たち ys の部分集合であれば、実際にボートに乗ることができます。
次はボートを動かして新しい局面を生成する関数 move-boat を作ります
リスト : ボートを動かして新しい局面を生成する
;;; 新しい局面を作る
(define (make-new-state st xs)
(if (eq? (get-boat st) 'left)
(make-state
'right
(difference eq? (get-left st) xs)
(union eq? (get-right st) xs))
(make-state
'left
(union eq? (get-left st) xs)
(difference eq? (get-right st) xs))))
;;; ボートを動かす
(define (move-boat st)
(filter (lambda (newst)
(and (safe? (get-left newst)) (safe? (get-right newst))))
(map (lambda (xs) (make-new-state st xs))
(get-riders st))))
関数 make-new-state は局面 st から新しい局面を生成します。xs はボートに乗る人を格納したリストです。ボートが左岸にある場合、ボートを right に、左岸から xs を削除し、右岸に xs を追加します。この処理は difference と union を使うと簡単です。ボートが右岸にある場合は、ボートを left に、左岸に xs を追加して、右岸から xs を削除します。
関数 move-boat は get-riders でボートに乗る人の組み合わせを求め、その要素に map で make-new-state を適用して新しい局面を作ります。そして、filter で安全な局面だけを取り出します。filter に渡すラムダ式で、左岸と右岸が安全かチェックしています。
あとは、幅優先探索か反復深化を使えば、最短手順を求めることができます。説明は割愛いたしますので、詳細は プログラムリスト３ をお読みください。
それでは実行してみましょう。
$ gosh -A . husband.scm ---- 0 ---- ---- 1 ---- ---- 2 ---- ---- 3 ---- ---- 4 ---- ---- 5 ---- ---- 6 ---- ---- 7 ---- ---- 8 ---- ---- 9 ---- ---- 10 ---- ---- 11 ---- left (Ha Wa Hb Wb Hc Wc) () right (Ha Hb Hc Wc) (Wa Wb) left (Ha Hb Hc Wc Wa) (Wb) right (Ha Hb Hc) (Wb Wa Wc) left (Ha Hb Hc Wa) (Wb Wc) right (Ha Wa) (Wb Wc Hb Hc) left (Ha Wa Hb Wb) (Wc Hc) right (Wa Wb) (Wc Hc Ha Hb) left (Wa Wb Wc) (Hc Ha Hb) right (Wc) (Hc Ha Hb Wa Wb) left (Wc Hc) (Ha Hb Wa Wb) right () (Ha Hb Wa Wb Hc Wc)
11 手で解くことができました。なお、Puzzle DE Programming では 「農夫と山羊と狼とキャベツの問題」 を取り上げています。興味のある方は参考にしてください。
●プログラムリスト３
;;;
;;; husband.scm : 嫉妬深い夫の問題
;;;
;;; Copyright (C) 2009-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write)
(mylib queue) ; プログラムリスト を参照
(mylib lset)) ; プログラムリスト を参照
;;; データと補助関数の定義
(define *pair* '((Wa . Ha) (Wb . Hb) (Wc . Hc)))
(define *male* '(Ha Hb Hc))
(define (male? x) (member x *male*))
(define (get-male x) (cdr (assoc x *pair*)))
;;; 局面の定義
(define-record-type State
(make-state boat left right)
state?
(boat get-boat)
(left get-left)
(right get-right))
;;; 局面の表示
(define (print-state st)
(display (get-boat st)) (display " ")
(display (get-left st)) (display " ")
(display (get-right st)) (newline))
;;; 集合の等値判定
(define (set-equal? xs ys)
(and (subset? eq? xs ys) (subset? eq? ys xs)))
;;; 同一局面のチェック
(define (state-equal? st1 st2)
(and (eq? (get-boat st1) (get-boat st2))
(set-equal? (get-left st1) (get-left st2))
(set-equal? (get-right st1) (get-right st2))))
;;; フィルター
(define (filter pred xs)
(cond
((null? xs) '())
((pred (car xs))
(cons (car xs) (filter pred (cdr xs))))
(else
(filter pred (cdr xs)))))
;;; すべての要素が pred を満たせば真を返す
(define (every pred xs)
(if (null? xs)
#t
(and (pred (car xs)) (every pred (cdr xs)))))
;;; 安全確認
(define (safe? ls)
(if (null? (intersection eq? ls *male*))
#t
(every (lambda (x)
(or (male? x) (member (get-male x) ls)))
ls)))
;;; ボートに乗る組み合わせを作る
(define riders-list
'((Ha) (Hb) (Hc)
(Wa) (Wb) (Wc)
(Ha Hb) (Ha Hc) (Hb Hc)
(Wa Wb) (Wa Wc) (Wb Wc)
(Ha Wa) (Hb Wb) (Hc Wc)))
(define (get-riders st)
(let ((ys (if (eq? (get-boat st) 'left) (get-left st) (get-right st))))
(filter (lambda (xs) (subset? eq? xs ys)) riders-list)))
;;; 新しい局面を作る
(define (make-new-state st xs)
(if (eq? (get-boat st) 'left)
(make-state
'right
(difference eq? (get-left st) xs)
(union eq? (get-right st) xs))
(make-state
'left
(union eq? (get-left st) xs)
(difference eq? (get-right st) xs))))
;;; ボートを動かす
(define (move-boat st)
(filter (lambda (newst)
(and (safe? (get-left newst)) (safe? (get-right newst))))
(map (lambda (xs) (make-new-state st xs))
(get-riders st))))
;;; 手順の表示
(define (print-answer move) (for-each print-state move))
;;; 幅優先探索
(define (solver start goal ret)
;; キューの生成
(define q (make-queue))
;; 初期化
(enqueue! q (list start))
(do ()
((queue-empty? q) #f)
(let ((move (dequeue! q)))
(cond
((state-equal? (car move) goal)
(print-answer (reverse move))
(ret #t))
(else
(for-each
(lambda (st)
(unless
(member st move state-equal?)
(enqueue! q (cons st move))))
(move-boat (car move))))))))
;;; 反復深化
(define (solver-ids start goal ret)
(define (dfs limit n move)
(if (= n limit)
(when
(state-equal? (car move) goal)
(print-answer (reverse move))
(ret #t))
(for-each
(lambda (st)
(unless
(member st move state-equal?)
(dfs limit (+ n 1) (cons st move))))
(move-boat (car move)))))
;;
(do ((x 0 (+ x 1)))
((>= x 20) #f)
(display "---- ") (display x) (display " ----\n")
(dfs x 0 (list start))))
;;; 実行
(call/cc
(lambda (cont)
(solver-ids
(make-state 'left '(Ha Wa Hb Wb Hc Wc) '())
(make-state 'right '() '(Ha Wa Hb Wb Hc Wc))
cont)))
●問題４「地図の配色問題」の解答
それではプログラムを作りましょう。今回の地図の配色は、単純な深さ優先探索で簡単に解くことができます。順番に地域の色を決めていきますが、このときに隣接している地域と異なる色を選びます。もし、色を選ぶことができなければ、バックトラックして前の地域に戻り違う色を選びます。
地域の色は連想リストで管理することにします。この場合、地域の色を求める関数 get-color と地域の色を更新する関数 set-color! は次のようになります。
リスト : 色のアクセス関数 ;;; 領域とその色 (define *region* '(A B C D E F G H I J K L)) (define *region-color* (map (lambda (x) (cons x #f)) *region*)) ;;; region の色を求める (define (get-color region) (cdr (assoc region *region-color*))) ;;; region の色を color にセットする (define (set-color! region color) (set-cdr! (assoc region *region-color*) color))
*region* は地域を表すリスト、*region-color* が地域と色を表す連想リストです。地域の色は #f で初期化します。関数 get-color は assoc で *region-color* から region を探索し、その cdr を返します。関数 set-color! は assoc で *region-color* から 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)
(let loop ((xs (cdr (assoc region *adjacent-map*))))
(cond
((null? xs) #f)
((eq? (get-color (car xs)) color) #t)
(else
(loop (cdr xs))))))
*adjacent-map* は隣接リストです。連想リストを使って定義していることに注意してください。same-color? は簡単で、 assoc で region の隣接リストを求め、named-let で color と同じ色が使われている地域を探索します。色はシンボル red, blue, green, yellow で表します。見つからない場合は #f を返します。
あとは単純な深さ優先探索で解くことができます。プログラムは次のようになります。
リスト : 地図の配色問題
(define (solver)
(define (dfs rs ret)
(cond
((null? rs)
(print-answer)
(ret #t))
(else
(for-each
(lambda (color)
(unless
(same-color? (car rs) color)
(set-color! (car rs) color)
(dfs (cdr rs) ret)
(set-color! (car rs) #f)))
'(red blue green yellow)))))
(call/cc
(lambda (cont) (dfs *region* cont))))
実際の処理は局所関数 dfs で行います。dfs は深さ優先探索で地域の色を順番に決めていきます。same-color? で隣り合った地域の色を確認し、同じ色がなければ dfs を再帰呼び出しします。同じ色が使われている場合は異なる色を選択します。解を一つ見つけたら print-answer で解を表示して処理を終了します。
それでは実行してみましょう。
$ gosh color.scm (A . red) (B . blue) (C . blue) (D . green) (E . red) (F . green) (G . yellow) (H . blue) (I . green) (J . red) (K . blue) (L . yellow)
確かに 4 色で解くことができました。
●プログラムリスト４
;;;
;;; color.scm : 地図の配色問題
;;;
;;; Copyright (C) 2009-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write))
;;; 隣接リスト
(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 *region* '(A B C D E F G H I J K L))
(define *region-color* (map (lambda (x) (cons x #f)) *region*))
;;; region の色を求める
(define (get-color region) (cdr (assoc region *region-color*)))
;;; region の色を color にセットする
(define (set-color! region color)
(set-cdr! (assoc region *region-color*) color))
;;; 同じ色が使われていないか確認する
(define (same-color? region color)
(let loop ((xs (cdr (assoc region *adjacent-map*))))
(cond
((null? xs) #f)
((eq? (get-color (car xs)) color) #t)
(else
(loop (cdr xs))))))
;;; 解の表示
(define (print-answer)
(for-each (lambda (x) (display x) (newline)) *region-color*))
;;; 解法
(define (solver)
(define (dfs rs ret)
(cond
((null? rs)
(print-answer)
(ret #t))
(else
(for-each
(lambda (color)
(unless
(same-color? (car rs) color)
(set-color! (car rs) color)
(dfs (cdr rs) ret)
(set-color! (car rs) #f)))
'(red blue green yellow)))))
(call/cc
(lambda (cont) (dfs *region* cont))))
;;; 実行
(solver)
●問題５「スライドパズル NO-OFF」の解答
それではプログラムを作りましょう。今回は盤面をベクタで表すことにします。盤面を表すデータ構造を下図に示します。
駒の種類はシンボルで表します。電球は 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
;;; 局面
(define-record-type State
(make-state board space prev)
state?
(board get-board)
(space get-space)
(prev get-prev-state))
局面はレコード型 State で表します。board は盤面、space は空き場所の位置、prev は 1 手前の局面を表します。
次は、駒を動かして新しい局面を生成する関数 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 st x)
(let ((board (get-board st))
(s (get-space st)))
(cond
((light? (get-board st) x)
(cond
((< s 2)
;; 左へ動かす
(make-state (make-new-board board s (+ s 2)) (+ s 2) st))
((< s 4)
;; 右へ動かす
(make-state (make-new-board board s (- s 2)) (- s 2) st))
(else #f)))
(else
;; 普通に動かす
(make-state (make-new-board board s x) x st)))))
関数 make-new-board は x の位置にある駒を空き場所 s の位置に動かして新しい盤面 new-board を作ります。関数 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.scm : スライドパズル NO-OFF
;;;
;;; Copyright (C) 2009-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write)
(mylib queue)) ; プログラムリスト を参照
;;; 隣接リスト
(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
;;; 局面
(define-record-type State
(make-state board space prev)
state?
(board get-board)
(space get-space)
(prev get-prev-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 st x)
(let ((board (get-board st))
(s (get-space st)))
(cond
((light? (get-board st) x)
(cond
((< s 2)
;; 左へ動かす
(make-state (make-new-board board s (+ s 2)) (+ s 2) st))
((< s 4)
;; 右へ動かす
(make-state (make-new-board board s (- s 2)) (- s 2) st))
(else #f)))
(else
;; 普通に動かす
(make-state (make-new-board board s x) x st)))))
;;; x と等しい要素の位置を求める
(define (vector-position x vec)
(let loop ((i 0))
(cond
((= i (vector-length vec)) #f)
((equal? x (vector-ref vec i)) i)
(else
(loop (+ i 1))))))
;;; 盤面の表示
(define (print-board board)
(do ((i 0 (+ i 1)))
((>= i (vector-length board)))
(display (vector-ref board i))
(display " ")
(if (= i 3) (newline)))
(newline)
(newline))
;;; 手順を表示
(define (print-answer st)
(when
(state? st)
(print-answer (get-prev-state st))
(print-board (get-board st))))
;;; 幅優先探索
(define (solver start goal ret)
(define que (make-queue))
(define tbl '())
;; 初期化
(enqueue! que (make-state start (vector-position 'S start) '()))
(set! tbl (cons start tbl))
(do ()
((queue-empty? que) #f)
(let ((st (dequeue! que)))
(cond
((equal? (get-board st) goal)
(print-answer st)
(ret #t))
(else
(for-each
(lambda (x)
(let ((newst (move-piece st x)))
(when
(and newst
(not (member (get-board newst) tbl)))
(enqueue! que newst)
(set! tbl (cons (get-board newst) tbl)))))
(vector-ref *adjacent-slide* (get-space st))))))))
;;; 問題
(define question-a #(L L O N O F F S))
(define question-b #(N O L L F O F S))
;;; 実行
(call/cc
(lambda (cont)
(solver question-b #(L L N O O F F S) cont)))
改訂 2020 年 9 月 19 日