パズルに挑戦 (1)
今回は簡単なパズルを 5 問出題します。Scheme で解法プログラムを作成してください。M.Hiroi は R7RS-small + 自作ライブラリ の範囲でプログラムを作ろうと思っています。他のライブラリを使うと、もっと簡単にプログラムを作ることができるかもしれません。みなさんも Scheme らしいプログラムを考えてみてください。
●小町算
1 から 9 までの数字を順番に並べ、間に + と - を補って 100 になる式を作ってください。なお、1 の前に符号 - は付けないものとします。
例 : 1 + 2 + 3 - 4 + 5 + 6 + 78 + 9 = 100
パズルの世界では、1 から 9 までの数字を 1 個ずつすべて使った数字を「小町数」といいます。たとえば、123456789 とか 321654987 のような数字です。「小町算」というものもあり、たとえば 123 + 456 + 789 とか 321 * 654 + 987 のようなものです。問題１は小町算の中でも特に有名なパズルです。
●覆面算
S E N D
+ M O R E
-------------
M O N E Y
図 : 覆面算
計算式の数字を文字や記号に置き換えて、それを元の数字に戻すパズルを「覆面算」といいます。異なる文字は異なる数字を表し、同じ文字は同じ数字を表します。使用する数字は 0 から 9 までで、最上位の桁に 0 を入れることはできません。
問題２はデュードニーが 1924 年に発表したもので、覆面算の古典といわれる有名なパズルです。
●蛙跳びゲーム
図 : 蛙跳びゲーム
蛙跳びゲームは黒石と白石を使って遊ぶ、いわゆる「飛び石ゲーム」と呼ばれる種類のパズルです。上図のように、蛙跳びゲームは黒石と白石を入れ替えることができれば成功です。スタートからゴールまでの最短手順を求めてください。
石を動かす規則は次のとおりです。
- 黒石は右へ、白石は左へ進む。いったん進んだ石は後戻りできない。
- 白石の左隣が空いている、または黒石の右隣が空いていれば、 その石は空いている場所へ移動できる。
- 白石の左隣が黒石で、その黒石の左隣が空いていれば、 白石は黒石を跳び越して空いている場所へ移動できる。
- 黒石の右隣が白石で、その白石の右隣が空いていれば、 黒石は白石を跳び越して空いている場所へ移動できる。
- 跳び越せる石は 1 個までで、2 個 3 個とまとめて跳び越すことはできない。 また、同じ色の石を跳び越すことはできない。
石の跳び越しは次の図を参考にしてください。
図 : 石の跳び越し
●川渡りの問題
3 人の宣教師と 3 人の先住民が川を渡ることになりました。川には 2 人乗りのボートが 1 そうしかありません。どのような時でも先住民の数が宣教師の数よりも多いと、宣教師は襲われてしまいます。6 人が安全に川を渡る最短手順を求めてください。
問題４は「川渡りの問題」とか「渡船問題」と呼ばれる古典的なパズルの一種です。その中でも「宣教師と先住民」は特に有名な問題です。
●油分け算
斗桶に油が 1 斗（= 10 升）あります。これを 5 升ずつ 2 つの油に分けたいのですが、手元には 7 升ますと 3 升ますが 1 つずつしかありません。この 2 つのますを使って油を二等分してください。
油分け算は江戸時代の和算書『塵劫記（じんこうき）』にある問題です。
●参考文献
- 奥村晴彦, 『Ｃ言語による最新アルゴリズム事典』, 技術評論社, 1991
- 中村義作, 『どこまで解ける日本の算法 和算で頭のトレーニング』, 講談社（ブルーバックス）, 1994
- 秋山仁, 中村義作, 『ゲームにひそむ数理』, 森北出版株式会社, 1998
●問題１「小町算」の解答
それではプログラムを作りましょう。式は次のようにリストで表すことにします。
1 + 2 + 3 - 4 + 5 + 6 + 78 + 9 => (1 + 2 + 3 - 4 + 5 + 6 + 78 + 9)
あとは、式を生成して値を計算するだけです。式を生成するとき、リストを逆順で管理すると簡単です。次の図を見てください。
(1) => (2 + 1) => (3 + 2 + 1)
=> (3 - 2 + 1)
=> (23 + 1)
=> (2 - 1) => (3 + 2 - 1)
=> (3 - 2 - 1)
=> (23 - 1)
=> (12) => (3 + 12)
=> (3 - 12)
=> (123)
式を生成するとき、リストに数字と演算子を順番に追加していきます。数字と + と - を追加する処理は簡単です。プログラムのポイントは数字を連結する処理、たとえば 1 と 2 を連結して一つの数値 12 にする処理です。この処理はリストの先頭の数字 1 を 12 (= 1 * 10 + 2) に置き換えることで実現できます。リストが (2 + 1) であれば、数字 2 を 23 (= 2 * 10 + 3) に置き換えます。
式を生成するプログラムは次のようになります。
リスト : 式の生成
(define (make-expr n expr ans)
(cond
((= n 10)
(calc-expr (reverse expr) ans))
(else
(make-expr (+ n 1) (cons n (cons + expr)) ans)
(make-expr (+ n 1) (cons n (cons - expr)) ans)
(make-expr (+ n 1) (cons (+ (* (car expr) 10) n) (cdr expr)) ans))))
make-expr の引数 n が追加する数字、expr が生成する式 (リスト)、ans が合計値です。最初に呼び出すとき、expr にはリスト (1) を渡します。n が 10 になったら関数 calc-expr で式 expr を計算します。
そうでなければ、数式を生成します。これは make-expr を再帰呼び出しするだけです。最初は n と + を追加します。次は n と - を追加します。このとき、+ と - は関数値で表すことに注意してください。最後は数字を連結する場合です。(+ (* (car expr) 10) n) を計算して、それと先頭の数字を置き換えます。
次は式を計算する関数 calc-expr を作ります。今回の問題は演算子に + と - しかないので、リストで表現した式を計算することは簡単です。次のプログラムを見てください。
リスト : 式の計算 (+ と - だけ)
(define (calc-expr expr ans)
(let loop ((ls (cdr expr)) (sum (car expr)))
(cond
((null? ls)
(when
(= ans sum)
(print-expr expr ans)))
(else
(loop (cddr ls) ((car ls) sum (cadr ls)))))))
先頭の数値を sum にセットし、loop で関数値 (+ または -) と数値を取り出して、sum に加算 (または減算) します。計算が終わったら sum と ans を比較し、同じ値であれば関数 print-expr で式 expr を表示します。print-expr は簡単なので説明は省略します。詳細は プログラムリスト１ をお読みください。
それでは実行結果を示します。
$ gosh komachi.scm 1 + 2 + 3 - 4 + 5 + 6 + 78 + 9 = 100 1 + 2 + 34 - 5 + 67 - 8 + 9 = 100 1 + 23 - 4 + 5 + 6 + 78 - 9 = 100 1 + 23 - 4 + 56 + 7 + 8 + 9 = 100 12 + 3 + 4 + 5 - 6 - 7 + 89 = 100 12 + 3 - 4 + 5 + 67 + 8 + 9 = 100 12 - 3 - 4 + 5 - 6 + 7 + 89 = 100 123 + 4 - 5 + 67 - 89 = 100 123 + 45 - 67 + 8 - 9 = 100 123 - 4 - 5 - 6 - 7 + 8 - 9 = 100 123 - 45 - 67 + 89 = 100
全部で 11 通りの解が出力されます。
●プログラムリスト１
;;;
;;; komachi.scm : 小町算
;;;
;;; Copyright (C) 2009-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write))
;;; 式の表示
(define (print-expr expr ans)
(for-each
(lambda (x)
(cond
((integer? x) (display x))
((eq? + x) (display " + "))
(else (display " - "))))
expr)
(display " = ")
(display ans)
(newline))
;;; 式の計算
(define (calc-expr expr ans)
(let loop ((ls (cdr expr)) (sum (car expr)))
(cond
((null? ls)
(when
(= ans sum)
(print-expr expr ans)))
(else
(loop (cddr ls) ((car ls) sum (cadr ls)))))))
;;; 式の生成
(define (make-expr n expr ans)
(cond
((= n 10)
(calc-expr (reverse expr) ans))
(else
(make-expr (+ n 1) (cons n (cons + expr)) ans)
(make-expr (+ n 1) (cons n (cons - expr)) ans)
(make-expr (+ n 1) (cons (+ (* (car expr) 10) n) (cdr expr)) ans))))
;;; 実行
(make-expr 2 '(1) 100)
●問題２「覆面算」の解答
それではプログラムを作ります。式 SEND + MORE = MONEY は足し算なので、M が 1 であることはすぐにわかります。ここでは、それ以外の数字を求めるプログラムを作ります。単純な生成検定法でプログラムを作ると、次のようになります。
::;
;:: hukumen.scm : 覆面算
;::
;:: Copyright (C) 2009-2020 Makoto Hiroi
;::
(import (scheme base) (scheme write))
;;; send + more = money
;;; (s e n d o r y)
;;; 0 1 2 3 4 5 6
;;; 畳み込み
(define (foldl fn a xs)
(if (null? xs)
a
(foldl fn (fn a (car xs)) (cdr xs))))
;;; 値を求める
(define (get-value ls . args)
(foldl (lambda (a x) (+ (* 10 a) (list-ref ls x))) 0 args))
;;; 条件を満たしているか
(define (check-money ls)
(let ((send (get-value ls 0 1 2 3))
(more (+ 1000 (get-value ls 4 5 1)))
(money (+ 10000 (get-value ls 4 2 1 6))))
(when
(= (+ send more) money)
(display send) (display " + ") (display more)
(display " = ") (display money) (newline))))
;;; 要素を削除する
(define (remove x ls)
(cond
((null? ls) '())
((equal? (car ls) x)
(remove x (cdr ls)))
(else
(cons (car ls) (remove x (cdr ls))))))
;;; 順列の生成
(define (permutations func n ls)
(define (perm ls n a)
(if (zero? n)
(func (reverse a))
(for-each
(lambda (x)
(perm (remove x ls) (- n 1) (cons x a)))
ls)))
(perm ls n '()))
;;; 実行
(permutations check-money 7 '(0 2 3 4 5 6 7 8 9))
1 を除いた 9 個の数字の中から数字を 7 個選ぶ順列を関数 permutations で生成します。permutations の説明は拙作のページ 順列と組み合わせ をお読みください。7 個の数字はリストに格納されいて、先頭から順番に s, e, n, d, o, r, y に対応します。
あとは述語 check-money で数値 send, more, money を計算して、send + more = money を満たしているかチェックします。数値の計算は関数 get-value で行います。たとえば send を計算する場合、生成した順列 ls と s, e, n, d の位置 0, 1, 2, 3 を渡します。この処理は畳み込みを行う関数 foldl を使うと簡単です。条件を満たしてれば display で値を表示します。
さっそく実行してみましょう。
$ gosh hukumen.scm 9567 + 1085 = 10652
答えは 9567 + 1085 = 10652 の 1 通りしかありません。興味のある方はもっとクールな方法を考えてみてください。
●問題３「蛙跳びゲーム」の解答
それではプログラムを作りましょう。このゲームは後戻りすることができないので、単純なバックトラックで最短手順を求めることができます。盤面はリストで表して、シンボル b を黒石、w を白石、s を空き場所と定義します。
蛙跳びゲームの場合、石の移動パターンは次に示す 4 通りしかありません。
- 黒石が右隣の空き場所へ移動 (move-black)
- 白石が左隣の空き場所へ移動 (move-white)
- 黒石が白石を跳び越して右側の空き場所へ移動 (jump-black)
- 白石が黒石を跳び越して左側の空き場所へ移動 (jump-white)
この 4 通りのパターンに対応する関数を定義します。黒石の移動を行う関数 move-black と jump-black は次のようになります。
リスト : 黒石の移動
;;; 黒石の移動
(define (move-black ls)
(cond
((null? ls) '())
((and (eq? (car ls) 'b)
(pair? (cdr ls))
(eq? (cadr ls) 's))
(cons 's (cons 'b (cddr ls))))
(else
(cons (car ls) (move-black (cdr ls))))))
;;; 黒石のジャンプ
(define (jump-black ls)
(cond
((null? ls) '())
((and (eq? (car ls) 'b)
(pair? (cdr ls))
(pair? (cddr ls))
(eq? (cadr ls) 'w)
(eq? (caddr ls) 's))
(cons 's (cons 'w (cons 'b (cdddr ls)))))
(else
(cons (car ls) (jump-black (cdr ls))))))
move-black と jump-black は黒石を移動した新しいリストを作ります。黒石を移動できない場合は引数 ls をコピーしたリストを返します。新しいリストが ls と等しい場合、石は移動できなかったことがわかります。もちろん、最初に石を動かすことができるか調べてから、実際に石を動かすようにプログラムすることもできます。興味のある方はプログラムを改造してみてください。
move-black は (car ls) が黒石 b ならば、右隣 (cadr ls) が空き場所 s であることを確認します。そうであれば、その石を空き場所へ移動します。jump-black は黒石 (car ls) の右隣 (cadr ls) が白石 w で、その右隣 (caddr ls) が空き場所 s の場合、空き場所の位置に黒石を移動します。
白石を動かす場合は、(car ls) が空き場所 s であるとき、右隣とその右隣の関係を確認します。あとは単純な深さ優先探索です。とくに難しいところはないので、説明は省略いたします。詳細は プログラムリスト３ をお読みくださいませ。
それでは実行結果を示します。
$ gosh kaeru.scm (b b b s w w w) (b b s b w w w) (b b w b s w w) (b b w b w s w) (b b w s w b w) (b s w b w b w) (s b w b w b w) (w b s b w b w) (w b w b s b w) (w b w b w b s) (w b w b w s b) (w b w s w b b) (w s w b w b b) (w w s b w b b) (w w w b s b b) (w w w s b b b) (b b b s w w w) (b b b w s w w) (b b s w b w w) (b s b w b w w) (b w b s b w w) (b w b w b s w) (b w b w b w s) (b w b w s w b) (b w s w b w b) (s w b w b w b) (w s b w b w b) (w w b s b w b) (w w b w b s b) (w w b w s b b) (w w s w b b b) (w w w s b b b)
15 手で解くことができました。蛙跳びゲームは 15 手よりも長い手順はありません。つまり、この回数でないと解くことができないのです。
●プログラムリスト３
;;;
;;; kaeru.scm : 蛙跳びゲーム
;;;
;;; Copyright (C) 2009-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write) (scheme cxr))
;;; 黒石の移動
(define (move-black ls)
(cond
((null? ls) '())
((and (eq? (car ls) 'b)
(pair? (cdr ls))
(eq? (cadr ls) 's))
(cons 's (cons 'b (cddr ls))))
(else
(cons (car ls) (move-black (cdr ls))))))
;;; 黒石のジャンプ
(define (jump-black ls)
(cond
((null? ls) '())
((and (eq? (car ls) 'b)
(pair? (cdr ls))
(pair? (cddr ls))
(eq? (cadr ls) 'w)
(eq? (caddr ls) 's))
(cons 's (cons 'w (cons 'b (cdddr ls)))))
(else
(cons (car ls) (jump-black (cdr ls))))))
;; 白石の移動
(define (move-white ls)
(cond
((null? ls) '())
((and (eq? (car ls) 's)
(pair? (cdr ls))
(eq? (cadr ls) 'w))
(cons 'w (cons 's (cddr ls))))
(else
(cons (car ls) (move-white (cdr ls))))))
;;; 白石のジャンプ
(define (jump-white ls)
(cond
((null? ls) '())
((and (eq? (car ls) 's)
(pair? (cdr ls))
(pair? (cddr ls))
(eq? (cadr ls) 'b)
(eq? (caddr ls) 'w))
(cons 'w (cons 'b (cons 's (cdddr ls)))))
(else
(cons (car ls) (jump-white (cdr ls))))))
;;; 移動関数表
(define func-list (list move-black move-white jump-black jump-white))
;;; 手順の表示
(define (print-answer move)
(for-each (lambda (x) (display x) (newline)) move)
(newline))
;;; 深さ優先探索
(define (solver-kaeru goal move)
(if (equal? goal (car move))
(print-answer (reverse move))
(for-each
(lambda (fn)
(let ((bs (fn (car move))))
(unless
(equal? bs (car move))
(solver-kaeru goal (cons bs move)))))
func-list)))
;;; 実行
(solver-kaeru '(w w w s b b b) '((b b b s w w w)))
●問題４「宣教師と先住民」の解答
それではプログラムを作ります。この問題は単純な「反復深化」で解くことができます。最初にデータ構造を定義しましょう。岸の状態 (局面) は次に示すレコード型 State で表すことにします。
リスト : 岸の状態を表すレコード型 (define-record-type State (make-state boat m-left e-left m-right e-right) state? (boat get-boat) ; left or right (m-left get-m-left) ; 左岸にいる宣教師の数 (e-left get-e-left) ; 左岸にいる先住民の数 (m-right get-m-right) ; 右岸にいる宣教師の数 (e-right get-e-right)) ; 右岸にいる先住民の数
次はボートを動かして新しい局面を生成する述語 move-boat を作ります。次のリストを見てください。
リスト : ボートを動かす
(define (move-boat st m e)
(if (eq? (get-boat st) 'left)
(make-state 'right
(- (get-m-left st) m)
(- (get-e-left st) e)
(+ (get-m-right st) m)
(+ (get-e-right st) e))
(make-state 'left
(+ (get-m-left st) m)
(+ (get-e-left st) e)
(- (get-m-right st) m)
(- (get-e-right st) e))))
move-boat の引数 st は現在の局面を表す State 型、m はボートに乗る宣教師の人数、e はボートに乗る先住民の人数です。ボートに乗る組み合わせを (m e) で表すと、(2 0), (0 2), (1 1), (1 0), (0 1) の 5 通りあります。ls から 5 通りの新しい状態を生成し、それが実現可能でかつ安全な状態かチェックします。今回は反復深化を使うので、同一局面のチェックは行っていません。
次は、宣教師が安全かチェックする述語 safe? と実現可能な局面かチェックする述語 possible? を作ります。次のリストを見てください。
リスト : 安全確認
;;; アクセス関数表
(define func-list (list get-boat get-m-left get-e-left get-m-right get-e-right))
;;; 安全か
(define (safe? st)
(or (and (<= (get-e-left st) (get-m-left st))
(<= (get-e-right st) (get-m-right st)))
(zero? (get-m-left st))
(zero? (get-m-right st))))
;;; 実現可能な局面か
(define (possible? st)
(every (lambda (fn) (<= 0 (fn st))) (cdr func-list)))
安全な状態は「先住民の人数 <= 宣教師の人数」だけではありません。この条件が成立しない場合でも、宣教師がいない場合は安全ですね。つまり、(left 3 2 0 1) のような状態は安全なわけです。したがって、(get-m-left st) または (get-m-right st) が 0 ならば安全と判定します。
pissible? は岸にいる人数がすべて 0 人以上であることを確認します。これは SRFI-1 の関数 every を使うと簡単です。今回は簡易バージョンを自作しました。
リスト : すべての要素が pred を満たせば #t を返す
(define (every pred xs)
(if (null? xs)
#t
(and (pred (car xs)) (every pred (cdr xs)))))
every は高階関数で、リストの要素に pred を適用し、すべての要素が真であれば真 (#t) を返します。偽となる要素が一つでもあると偽 (#f) を返します。
あとは単純な反復深化なので、説明は省略いたします。詳細は プログラムリスト４ をお読みくださいませ。
それでは実行結果を示します。
$ gosh river.scm ---- 1 ---- ---- 2 ---- ---- 3 ---- ---- 4 ---- ---- 5 ---- ---- 6 ---- ---- 7 ---- ---- 8 ---- ---- 9 ---- ---- 10 ---- ---- 11 ---- left 3 3 0 0 right 2 2 1 1 left 3 2 0 1 right 3 0 0 3 left 3 1 0 2 right 1 1 2 2 left 2 2 1 1 right 0 2 3 1 left 0 3 3 0 right 0 1 3 2 left 1 1 2 2 right 0 0 3 3
最短手数は 11 手になります。川渡りの問題はいろいろなバリエーションがあります。興味のある方は、拙作のページ Puzzle DE Programming の 農夫と山羊と狼とキャベツの問題 や 嫉妬深い夫の問題 をお読みくださいませ。
●プログラムリスト４
;;;
;;; river.scm : 川渡り問題
;;;
;;; Copyright (C) 2009-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write))
;;; 岸の状態を表すレコード型
(define-record-type State
(make-state boat m-left e-left m-right e-right)
state?
(boat get-boat)
(m-left get-m-left)
(e-left get-e-left)
(m-right get-m-right)
(e-right get-e-right))
;;; アクセス関数表
(define func-list (list get-boat get-m-left get-e-left get-m-right get-e-right))
;;; State の表示
(define (print-state st)
(for-each
(lambda (fn) (display (fn st)) (display " "))
func-list)
(newline))
;;; すべての要素が pred を満たせば #t を返す
(define (every pred xs)
(if (null? xs)
#t
(and (pred (car xs)) (every pred (cdr xs)))))
;;; 等値の判定
(define (state-equal? st1 st2)
(every (lambda (fn) (eqv? (fn st1) (fn st2))) func-list))
;;; ボートを動かす
(define (move-boat st m e)
(if (eq? (get-boat st) 'left)
(make-state 'right
(- (get-m-left st) m)
(- (get-e-left st) e)
(+ (get-m-right st) m)
(+ (get-e-right st) e))
(make-state 'left
(+ (get-m-left st) m)
(+ (get-e-left st) e)
(- (get-m-right st) m)
(- (get-e-right st) e))))
;;; 安全か
(define (safe? st)
(or (and (<= (get-e-left st) (get-m-left st))
(<= (get-e-right st) (get-m-right st)))
(zero? (get-m-left st))
(zero? (get-m-right st))))
;;; 実現可能な局面か
(define (possible? st)
(every (lambda (fn) (<= 0 (fn st))) (cdr func-list)))
;;; 手順の表示
(define (print-answer move) (for-each print-state move))
;;; 反復深化による解法
(define (solver-river start goal)
(define (dfs limit n move ret)
(cond
((= n limit)
(when
(state-equal? (car move) goal)
(print-answer (reverse move))
(ret #t)))
(else
(for-each
(lambda (x)
(let ((st (apply move-boat (car move) x)))
(when
(and (possible? st) (safe? st))
(dfs limit (+ n 1) (cons st move) ret))))
'((1 0) (0 1) (1 1) (2 0) (0 2))))))
;;
(call/cc
(lambda (cont)
(do ((x 1 (+ x 1)))
((>= x 20) #f)
(display "---- ") (display x) (display " ----\n")
(dfs x 0 (list start) cont)))))
;;; 実行
(solver-river (make-state 'left 3 3 0 0) (make-state 'right 0 0 3 3))
●問題５「油分け算」の解答
それではプログラムを作りましょう。斗桶 (a) と 7 升ます (b) と 3 升ます (c) の状態をレコード型 State で表すことにします。
リスト : 局面の定義 (define-record-type State (make-state a b c) state? (a get-oil-a) (b get-oil-b) (c get-oil-c))
油分け算の場合、次に示す 3 通りの操作があります。
- 斗桶からますへ油を注ぐ。
- ますの油を斗桶に戻す。
- 他のますに油を移す。
ますは 2 つあるので、操作は全部で 6 通りになります。この操作を transfer1 から transfer6 までの 6 つの関数で定義します。次のリストを見てください。
リスト : 油を移す操作
;;; 容量の定義
(define max-a 10)
(define max-b 7)
(define max-c 3)
;;; 空き容量を求める
(define (get-space-a st) (- max-a (get-oil-a st)))
(define (get-space-b st) (- max-b (get-oil-b st)))
(define (get-space-c st) (- max-c (get-oil-c st)))
;;; a -> b
(define (transfer1 st)
(let ((move-oil (min (get-space-b st) (get-oil-a st))))
(make-state (- (get-oil-a st) move-oil)
(+ (get-oil-b st) move-oil)
(get-oil-c st))))
;;; a -> c
(define (transfer2 st)
(let ((move-oil (min (get-space-c st) (get-oil-a st))))
(make-state (- (get-oil-a st) move-oil)
(get-oil-b st)
(+ (get-oil-c st) move-oil))))
;;; b -> a
(define (transfer3 st)
(make-state (+ (get-oil-a st) (get-oil-b st))
0
(get-oil-c st)))
;;; b -> c
(define (transfer4 st)
(let ((move-oil (min (get-space-c st) (get-oil-b st))))
(make-state (get-oil-a st)
(- (get-oil-b st) move-oil)
(+ (get-oil-c st) move-oil))))
;;; c -> a
(define (transfer5 st)
(make-state (+ (get-oil-a st) (get-oil-c st))
(get-oil-b st)
0))
;;; c -> b
(define (transfer6 st)
(let ((move-oil (min (get-space-b st) (get-oil-c st))))
(make-state (get-oil-a st)
(+ (get-oil-b st) move-oil)
(- (get-oil-c st) move-oil))))
;;; 操作関数表
(define transfer
(list transfer1 transfer2 transfer3 transfer4 transfer5 transfer6))
関数 get-oil-? は油の容量を求めます。関数 set-space-? は空き容量を求めます。引数 st は各ますの状態を表す State 型です。油を移すとき、たとえば a から b に移すときは、a の油の容量と b の空き容量を比較して、少ないほうが移す油の量 move-oil になります。a に油を移す場合は a の空き容量をチェックする必要はありません。また、move-oil が 0 の場合は油を移すことができません。この場合は、引数 st と等しい State 型が生成されるので、探索のときにチェックします。
あとは、幅優先探索か反復深化を使って簡単に解くことができます。今回は幅優先探索でプログラムを作りました。とくに難しいところはないので、説明は省略いたします。詳細は プログラムリスト５ をお読みくださいませ。
それでは実行結果を示します。
$ gosh -A . abura.scm 10 0 0 3 7 0 3 4 3 6 4 0 6 1 3 9 1 0 9 0 1 2 7 1 2 5 3 5 5 0
最短手数は 9 手になりました。反復深化でも簡単にプログラムを作ることができるので、興味のある方は挑戦してみてください。
●プログラムリスト５
;;;
;;; abura.scm : 油分け算
;;;
;;; Copyright (C) 2009-2020 Makoto Hiroi
;;;
(import (scheme base) (scheme write)
(mylib queue)) ; プログラムリスト を参照
;;; 容量の定義
(define max-a 10)
(define max-b 7)
(define max-c 3)
;;; 局面の定義
(define-record-type State
(make-state a b c)
state?
(a get-oil-a)
(b get-oil-b)
(c get-oil-c))
;;; 操作関数表
(define func-list (list get-oil-a get-oil-b get-oil-c))
;;; 局面の表示
(define (print-state st)
(for-each
(lambda (fn)
(display (fn st)) (display " "))
func-list)
(newline))
;;; すべての要素が pred を満たせば #t を返す
(define (every pred xs)
(if (null? xs)
#t
(and (pred (car xs)) (every pred (cdr xs)))))
;;; 等値の判定
(define (state-equal? st1 st2)
(every (lambda (fn) (eqv? (fn st1) (fn st2))) func-list))
;;; 空き容量を求める
(define (get-space-a st) (- max-a (get-oil-a st)))
(define (get-space-b st) (- max-b (get-oil-b st)))
(define (get-space-c st) (- max-c (get-oil-c st)))
;;; a -> b
(define (transfer1 st)
(let ((move-oil (min (get-space-b st) (get-oil-a st))))
(make-state (- (get-oil-a st) move-oil)
(+ (get-oil-b st) move-oil)
(get-oil-c st))))
;;; a -> c
(define (transfer2 st)
(let ((move-oil (min (get-space-c st) (get-oil-a st))))
(make-state (- (get-oil-a st) move-oil)
(get-oil-b st)
(+ (get-oil-c st) move-oil))))
;;; b -> a
(define (transfer3 st)
(make-state (+ (get-oil-a st) (get-oil-b st))
0
(get-oil-c st)))
;;; b -> c
(define (transfer4 st)
(let ((move-oil (min (get-space-c st) (get-oil-b st))))
(make-state (get-oil-a st)
(- (get-oil-b st) move-oil)
(+ (get-oil-c st) move-oil))))
;;; c -> a
(define (transfer5 st)
(make-state (+ (get-oil-a st) (get-oil-c st))
(get-oil-b st)
0))
;;; c -> b
(define (transfer6 st)
(let ((move-oil (min (get-space-b st) (get-oil-c st))))
(make-state (get-oil-a st)
(+ (get-oil-b st) move-oil)
(- (get-oil-c st) move-oil))))
;;; 操作関数表
(define transfer
(list transfer1 transfer2 transfer3 transfer4 transfer5 transfer6))
;;; 手順の表示
(define (print-answer move) (for-each print-state move))
;;; 幅優先探索
(define (bfs 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 (fn)
(let ((st (fn (car move))))
(unless
(member st move state-equal?)
(enqueue! q (cons st move)))))
transfer))))))
;;; 実行
(call/cc
(lambda (cont)
(bfs (make-state 10 0 0) (make-state 5 5 0) cont)))
改訂 2020 年 9 月 19 日