今回も簡単なパズルを 5 問出題します。Scheme で解法プログラムを作成してください。M.Hiroi は R7RS-samll + 自作ライブラリ の範囲でプログラムを作ろうと思っています。他のライブラリを使うと、もっと簡単にプログラムを作ることができるかもしれません。みなさんも Scheme らしいプログラムを考えてみてください。
Four Fours は数字を使ったパズルです。いろいろなルールがあるのですが、今回は簡易ルールで行きましょう。それでは問題です。
数字 4 を 4 つと＋, －, ×, ÷, （, ） を使って、答えが 1 から 10 になる式を作ってください。数字は 4 だけではなく、44 や 444 のように合体させてもかまいません。また、－を符号として使うことは禁止します。
数字の 4 を 4 つ使うので Four Fours という名前なのだと思います。ところで、このルールでは 11 になる式を作ることができません。ほかのルール、たとえば小数点を付け加えると、次のように作ることができます。
4 ÷ .4 ＋ 4 ÷ 4 = 11
今回は簡易ルールということで、小数点を使わないで 1 から 10 までの式を作ってください。
騎士 (ナイト) はチェスの駒のひとつで、下図に示すように将棋の桂馬の動きを前後左右にとることができます。今回は黒騎士 ● と白騎士 ○ の位置を交換するパズルです。それでは問題です。
下図の START から GOAL までの最短手順を求めてください。
┌─┬─┬─┬─┬─┐
│ │◎│ │◎│ │
├─┼─┼─┼─┼─┤ ┌─┬─┬─┐ ┌─┬─┬─┐
│◎│ │ │ │◎│ │●│ │●│ │○│ │○│
├─┼─┼─┼─┼─┤ ├─┼─┼─┤ ├─┼─┼─┤
│ │ │Ｋ│ │ │ │ │ │ │ │ │ │ │
├─┼─┼─┼─┼─┤ ├─┼─┼─┤ => ├─┼─┼─┤
│◎│ │ │ │◎│ │ │ │ │ │ │ │ │
├─┼─┼─┼─┼─┤ ├─┼─┼─┤ ├─┼─┼─┤
│ │◎│ │◎│ │ │○│ │○│ │●│ │●│
└─┴─┴─┴─┴─┘ └─┴─┴─┘ └─┴─┴─┘
◎ : ナイト (K) が動ける位置 ＳＴＡＲＴ ＧＯＡＬ
図 : 騎士の交換
チャイニーズ・チェッカーは「ペグ・ソリテア」と呼ばれるパズルのひとつです。ペグ・ソリテアは、盤上に配置されたペグ (駒) を、最後にはひとつ残るように取り除いていく古典的なパズルです。ペグは次のルールに従って移動し、除去することができます。
盤は今までに多数考案されていますが、33 穴英国盤、37 穴フランス盤、41 穴盤が有名でしょう。33 穴英国盤とチャイニーズ・チェッカーを図に示します。
●─●─●
│ │ │
●─●─●
│ │ │ ●
●─●─●─●─●─●─● ／ ＼
│ │ │ │ │ │ │ ●───●
●─●─●─○─●─●─● ／ ＼ ／ ＼
│ │ │ │ │ │ │ ●───●───●
●─●─●─●─●─●─● ／ ＼ ／ ＼ ／ ＼
│ │ │ ●───●───●───●
●─●─● ／ ＼ ／ ＼ ／ ＼ ／ ＼
│ │ │ ●───●───○───●───●
●─●─●
(1) 33 穴英国盤 (2) チャイニーズ・チェッカー
図 : ペグ・ソリテア
それぞれのマスにペグがありますが、そこからひとつペグを取り除いてゲームを始めます。図では黒丸でペグを表し、白丸で空き場所を表しています。ルールに従ってペグを移動し、最後にひとつだけ残ればクリアとなります。
それでは問題です。図 (2) に示したように、下辺の中央のペグを取り除きます。この状態から始めて、最後のペグが最初に取り除いた位置に残る跳び方の最小手数を求めてください。
「８めくり」は Puzzle DE Programming で取り上げた「ライツアウト」に類似のパズルです。ルールは簡単で、あるボタンを押すと周囲のボタンの状態が反転します。つまり、光っているボタンは消灯し、消えていたボタンは点灯します。次の図を見てください。
０１２
３４５ ボタンの番号
６７８
□□□ ■■■ □□□ □■□ □□□ ■□■
□□□ ←→ ■□■ □□□ ←→ ■■□ □□□ ←→ ■■■
□□□ ■■■ □□□ □□□ □□□ □□□
４を押す ０を押す １を押す
図 : 反転パターン
中央のボタン 4 を押すと、その周囲のボタン 8 個の状態が反転します。押したボタンの状態は反転しません。もう一度同じボタンを押すと、再度ボタンの状態が反転するので、元の状態に戻ります。隅のボタン 0 を押すと 3 個のボタンの状態が反転し、辺にあるボタン 1 を押すと 5 個のボタンの状態が反転します。
それでは問題です。
□□□□ □□□□ □□□□ □□□□ 図 : 4 * 4 盤
上図に示す 4 行 4 列盤で、全てのボタンを消灯する最小手順を求めてください。
最後はちょっと変わったスライドパズルです。3 行 3 列の盤面において、縦横斜めの８方向に駒をスライドさせます。次の図を見てください。
5 2 3 1 5 3 1 2 5
4 9 6 4 8 6 4 7 6
7 8 1 7 2 9 3 8 9
＼ │ ／
┌─┬─┬─┐
│１│２│３│
1 2 3 ├─┼─┼─┤ 1 2 3
5 6 4 ─│４│５│６│─ 6 4 5
7 8 9 ├─┼─┼─┤ 7 8 9
│７│８│９│
└─┴─┴─┘
／ │ ＼
1 2 7 1 8 3 9 2 3
4 3 6 4 2 6 4 1 6
5 8 9 7 5 9 7 8 5
図 : スライドパズルの動作
上下方向にスライドできるのは (2 5 8) の列で、上にスライドすると 2 が下に移動して (5 8 2) になります。逆に下にスライドすると 8 が上に移動して (8 2 5) になります。同様に、左右にスライドできるのが (4 5 6) の行で、斜め方向に移動できるのが対角線の (1 5 9) と (3 5 7) です。
それでは問題です。
┌─┬─┬─┐ ┌─┬─┬─┐ │９│８│７│ │１│２│３│ ├─┼─┼─┤ ├─┼─┼─┤ │６│５│４│ => │４│５│６│ ├─┼─┼─┤ ├─┼─┼─┤ │３│２│１│ │７│８│９│ └─┴─┴─┘ └─┴─┴─┘ ＳＴＡＲＴ ＧＯＡＬ
START から GOAL までの最短手順を求めてください。
それではプログラムを作りましょう。Four Fours の場合、4 つの数値に 3 つの演算子だけなので、数式のパターンは次に示す 5 種類しかありません。
(1) (4 Y 4) X (4 Z 4) (2) 4 X (4 Y (4 Z 4)) (3) ((4 Z 4) Y 4) X 4 (4) 4 X ((4 Z 4) Y 4) (5) (4 Y (4 Z 4)) X 4
あとは、X, Y, Z に演算子 +, -, *, / を入れて数式を計算すればいいわけです。Four Fours は数字を合体できるので、数字が 3 つで演算子が 2 つ、数字が 2 つで演算子がひとつ、というパターンもあります。演算子がひとつの場合は簡単ですね。演算子が 2 つの場合は、次の式になります。
(A) (a Y b) X c (B) a X (b Y c)
a, b, c が数字で X, Y が演算子を表しています。数字は 4 か 44 になります。この場合、a, b, c の組み合わせを生成する必要があります。組み合わせを (a, b, c) で表すと、(4, 4, 44), (4, 44, 4), (44, 4, 4) の 3 通りとなります。これと演算子の組み合わせにより数式を生成して、答えを求めてチェックします。
これらの数式を Scheme でプログラムすると次のようになります。
リスト : 数式 ;;; 数式を表すレコード型 (define-record-type Expr (make-expr left op right) expr? (left get-left) (op get-op) (right get-right)) ;;; (1) (4 Y 4) X (4 Z 4) (define (expr1 x y z) (make-expr (make-expr 4 y 4) x (make-expr 4 z 4))) ;;; (2) 4 X (4 Y (4 Z 4)) (define (expr2 x y z) (make-expr 4 x (make-expr 4 y (make-expr 4 z 4)))) ;;; (3) ((4 Z 4) Y 4) X 4 (define (expr3 x y z) (make-expr (make-expr (make-expr 4 z 4) y 4) x 4)) ;;; (4) 4 X ((4 Z 4) Y 4) (define (expr4 x y z) (make-expr 4 x (make-expr (make-expr 4 z 4) y 4))) ;;; (5) (4 Y (4 Z 4)) X 4 (define (expr5 x y z) (make-expr (make-expr 4 y (make-expr 4 z 4)) x 4)) ;;; (A) (a Y b) X c (define (expr-a a b c x y) (make-expr (make-expr a y b) x c)) ;;; (B) a X (b Y c) (define (expr-b a b c x y) (make-expr a x (make-expr b y c)))
最初に、数式を表すレコード型 Expr を定義します。Expr は二分木と同じデータ構造で、left が左辺式、op が演算子、right が右辺式を表します。関数 expr1 - expr5 は (1) から (5) の数式を生成します。引数 x, y, z が演算子を表します。これらの引数はシンボル +, - *, / を渡します。expr-a と expr-b は数式 (A) と (B) を生成します。引数 a, b, c は数値を表します。
数式の計算も簡単です。次のリストを見てください。
リスト : 数式の計算
(define (calc-expr expr)
(define (calc expr)
(cond
((expr? expr)
(let ((lv (calc (get-left expr)))
(rv (calc (get-right expr))))
(case (get-op expr)
((+) (+ lv rv))
((-) (- lv rv))
((*) (* lv rv))
((/) (/ lv rv))
(else
(error "invalid operator")))))
(else expr)))
;; ゼロ除算を捕捉
(guard (exc (else #f)) (calc expr)))
実際の処理は局所関数 calc で行います。引数 expr が Expr 型の場合、calc を再帰呼び出しして、左辺式と右辺式を計算します。あとは case で演算子に対応した計算を行います。expr が Expr 型でなければ数値なので、expr をそのまま返します。なお、Gauche は 0 で除算すると例外が送出されるので、それを guard で捕捉します。その場合は #f を返します。
解法プログラムは次のようになります。
リスト : Four Forus の解法
(define (check expr)
(let ((num (calc-expr expr)))
(when
(and (integer? num) (<= 1 num 10))
(print-expr expr)
(display " = ")
(display num)
(newline))))
(define (solver4)
(let loop ((xs '()))
(cond
((= (length xs) 3)
(for-each
(lambda (proc) (check (apply proc xs)))
(list expr1 expr2 expr3 expr4 expr5)))
(else
(for-each
(lambda (op) (loop (cons op xs)))
'(+ - * /))))))
関数 solver4 は演算子が 3 つの数式を計算して、結果が 1 以上 10 以下の整数値であれば、その式と値を表示します。演算子の組み合わせは「順列と組み合わせ」の問題 2 で取り上げた「重複順列」と同じです。else 節の for-each で演算子を一つ選んで xs に格納し、solver4 を再帰呼び出しします。そして、xs の長さが 3 になったら、関数 expr1 - expr5 に演算子 xs を渡して数式を生成し、関数 check で数式の計算とその結果を確認します。
関数 check では、calc で数式 expr を計算して、その結果を変数 num にセットします。あとは num の値をチェックして、条件を満たしていたら関数 print-expr を呼び出して数式と num を表示するだけです。それから、演算子が 2 つの数式を計算する solver3 と演算子が 1 つの数式を計算する solver2 を作成します。これらのプログラムは簡単なので説明は割愛いたします。詳細はプログラムリスト１をお読みください。
実際に実行すると 100 通りの数式が出力されますが、値が 10 となる数式は次に示す 1 通りしかありません。
(44 - 4) / 4 = 10
興味のある方はいろいろ試してみてください。
;;;
;;; fourfours.scm : Four Fours の解法
;;;
;;; Copyright (C) 2010-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write))
;;; 数式を表すレコード型
(define-record-type Expr
(make-expr left op right)
expr?
(left get-left)
(op get-op)
(right get-right))
;;; 表示
(define (print-expr expr)
(cond
((expr? expr)
(display "(")
(print-expr (get-left expr))
(display " ")
(display (get-op expr))
(display " ")
(print-expr (get-right expr))
(display ")"))
(else
(display expr))))
;;; 数式の計算
(define (calc-expr expr)
(define (calc expr)
(cond
((expr? expr)
(let ((lv (calc (get-left expr)))
(rv (calc (get-right expr))))
(case (get-op expr)
((+) (+ lv rv))
((-) (- lv rv))
((*) (* lv rv))
((/) (/ lv rv))
(else
(error "invalid operator")))))
(else expr)))
;; ゼロ除算を捕捉
(guard (exc (else #f)) (calc expr)))
;;; (1) (4 Y 4) X (4 Z 4)
(define (expr1 x y z)
(make-expr (make-expr 4 y 4) x (make-expr 4 z 4)))
;;; (2) 4 X (4 Y (4 Z 4))
(define (expr2 x y z)
(make-expr 4 x (make-expr 4 y (make-expr 4 z 4))))
;;; (3) ((4 Z 4) Y 4) X 4
(define (expr3 x y z)
(make-expr (make-expr (make-expr 4 z 4) y 4) x 4))
;;; (4) 4 X ((4 Z 4) Y 4)
(define (expr4 x y z)
(make-expr 4 x (make-expr (make-expr 4 z 4) y 4)))
;;; (5) (4 Y (4 Z 4)) X 4
(define (expr5 x y z)
(make-expr (make-expr 4 y (make-expr 4 z 4)) x 4))
;;; (A) (a Y b) X c
(define (expr-a a b c x y)
(make-expr (make-expr a y b) x c))
;;; (B) a X (b Y c)
(define (expr-b a b c x y)
(make-expr a x (make-expr b y c)))
(define (check expr)
(let ((num (calc-expr expr)))
(when
(and (integer? num) (<= 1 num 10))
(print-expr expr)
(display " = ")
(display num)
(newline))))
(define (solver4)
(let loop ((xs '()))
(cond
((= (length xs) 3)
(for-each
(lambda (proc) (check (apply proc xs)))
(list expr1 expr2 expr3 expr4 expr5)))
(else
(for-each
(lambda (op) (loop (cons op xs)))
'(+ - * /))))))
(define (solver3 a b c)
(let loop ((xs '()))
(cond
((= (length xs) 2)
(for-each
(lambda (proc) (check (apply proc a b c xs)))
(list expr-a expr-b)))
(else
(for-each
(lambda (op) (loop (cons op xs)))
'(+ - * /))))))
(define (solver2 a b)
(for-each
(lambda (op) (check (make-expr a op b)))
'(+ - * /)))
;;; 実行
(solver4)
(solver3 44 4 4)
(solver3 4 44 4)
(solver3 4 4 44)
(solver2 4 444)
(solver2 44 44)
(solver2 444 4)
それではプログラムを作りましょう。次の図を見てください。
┌─┬─┬─┐
│０│１│２│ ０──７──２ ●──７──●
├─┼─┼─┤ │ │ │ │
│３│４│５│ ５──10──３ ５──10──３
├─┼─┼─┤ │ │ │ │
│６│７│８│ ６──１──８ ６──１──８
├─┼─┼─┤ │ │ │ │
│９│10│11│ 11──４──９ ○──４──○
└─┴─┴─┘
（Ａ）盤面 （Ｂ）騎士の移動 （Ｃ）ＳＴＡＲＴ
図 : 騎士の移動
図 (A) のように、盤面の各マスに番号を付けて表します。すると、騎士の移動は図 (B) のようなグラフで表すことができます。START の局面は図 (C) のようになるので、黒騎士と白騎士を交換できることは簡単にわかりますが、最短手数となる移動手順を求めるのが今回の問題です。
このパズルは 12 マスに 2 個の黒騎士を置き、残りの 10 マスに白騎士を置くわけですから、局面の総数は次のようになります。
12Ｃ2 * 10Ｃ2 = 66 * 45 = 2970 通り
局面の総数は 2970 通りしかないので、幅優先探索を使えば簡単に解くことができます。同一局面のチェックも線形探索で十分でしょう。
まず最初に、跳び先表と局面を表すレコード型を定義します。
リスト : 跳び先表とレコード型の定義
;;; 跳び先表
(define *jump-table*
#((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
;;; 局面を表すレコード型
(define-record-type State
(make-state board prev)
state?
(board get-board)
(prev get-prev))
跳び先表は *jump-table* で定義します。局面を表すレコード型は名前を State とし、board に盤面を、prev に 1 手前の局面を格納します。盤面はベクタで表します。黒騎士をシンボル b で、白騎士を w で、空き場所を s で表すことにします。
次は騎士を移動して新しい盤面を作る関数 move-knight を作ります。
リスト : 騎士の移動
(define (move-knight board from to)
(let ((newbd (vector-copy board)))
(vector-set! newbd to (vector-ref newbd from))
(vector-set! newbd from 's)
newbd))
move-knight は簡単です。vector-copy で引数 board をコピーし、to に from の位置の騎士を、from に空き場所 s をセットするだけです。「便利なベクタ操作関数」で作成した関数 vector-swap! を使ってもかまいません。
あとは単純な幅優先探索なので説明は割愛いたします。詳細はプログラムリスト２をお読みください。
最短手数は 16 手で手順は次のようになります。
b s b
s s s
s s s
w s w
[START]
s s b s s s s s s s s s s b s s b s s b s s s s
s s b b s b s s b s s s s s s s s s s s w s s w
s s s s s s s s b b s b s s b w s b s s b b s b
w s w w s w w s w w s w w s w w s s w s s w s s
[1] [2] [3] [4] [5] [6] [7] [8]
w s s w s s w b s w b s w b s w s s w s w w s w
s s s s s s s s s s s s w s s w s s s s s s s s
b s b s s b s s s s s w s s s s s b s s b s s s
w s s w s b w s b s s b s s b s s b s s b b s b
[9] [10] [11] [12] [13] [14] [15] [16:GOAL]
図 : 最短手順の一例
ちなみに、最長手数の局面を幅優先探索 (関数 bfs-max) で求めたところ、手数は 18 手で次に示す 4 通りの局面が見つかりました。
s s b s s b b s s b s s
s w s s w s s w s s w s
s b s s b s s b s s b s
w s s s s w s s w w s s
図 : 最長手数の局面
ちなみに、生成した全局面は 2970 個になりました。しがたって、このパズルでは騎士をランダムに配置しても、必ず START の局面に到達できることがわかります。
;;;
;;; knightc.scm : 騎士の交換
;;;
;;; Copyright (C) 2010-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write)
(mylib queue) ; プログラムリスト "abcscm17.html#list3" を参照
(mylib vector)) ; プログラムリスト "abcscm25a.html#list1" を参照
;;; 大きさ
(define *size* 12)
;;; 跳び先表
(define *jump-table*
#((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
;;; 局面
(define-record-type State
(make-state board prev)
state?
(board get-board)
(prev get-prev))
;;; 盤面の表示
(define (print-board board)
(vector-for-each-with-index
(lambda (i k)
(display k)
(display " ")
(when
(zero? (modulo (+ i 1) 3))
(newline)))
board)
(newline))
;;; 手順の表示
(define (print-answer st)
(when
(state? st)
(print-answer (get-prev st))
(print-board (get-board st))))
;;; 騎士の移動
(define (move-knight board from to)
(let ((newbd (vector-copy board)))
(vector-set! newbd to (vector-ref newbd from))
(vector-set! newbd from 's)
newbd))
;;; 空き場所か
(define (space? board x) (eq? (vector-ref board x) 's))
;;; 幅優先探索
(define (bfs start goal ret)
(let ((que (make-queue))
(tbl '()))
(enqueue! que (make-state start '()))
(set! tbl (cons start tbl))
(do ()
((queue-empty? que) #f)
(let* ((st (dequeue! que))
(bd (get-board st)))
(vector-for-each-with-index
(lambda (from k)
(unless
(eq? k 's)
(for-each
(lambda (to)
(when
(space? bd to)
(let* ((newbd (move-knight bd from to))
(newst (make-state newbd st)))
(cond
((equal? newbd goal)
(print-answer newst)
(ret #t))
((not (member newbd tbl equal?))
(set! tbl (cons newbd tbl))
(enqueue! que newst))))))
(vector-ref *jump-table* from))))
bd)))))
;;; 最長手数の探索
(define (bfs-max start)
(let ((tbl (list start)))
(let loop ((olds (list start)) (i 0))
(let ((news '()))
(for-each
(lambda (bd)
(vector-for-each-with-index
(lambda (from k)
(unless
(eq? k 's)
(for-each
(lambda (to)
(when
(space? bd to)
(let ((newbd (move-knight bd from to)))
(unless
(member newbd tbl equal?)
(set! tbl (cons newbd tbl))
(set! news (cons newbd news))))))
(vector-ref *jump-table* from))))
bd))
olds)
;;
(cond
((null? news)
(for-each print-board olds)
(display i)
(newline)
(display (length tbl))
(newline))
(else
(loop news (+ i 1))))))))
;;; 実行
(call/cc
(lambda (cont)
(bfs #(b s b s s s s s s w s w) #(w s w s s s s s s b s b) cont)))
;;; (bfs-max #(w s w s s s s s s b s b))