一般に、関数の返り値はひとつしかありません。複数の値を返す場合、Scheme / Lisp ではリストに格納して返すのが普通です。この場合、返す側は必要なデータをリストに格納し、受け取る側はリストからデータを取り出す処理が必要になります。ところが、Scheme の「多値 (Multiple Values) 」という機能を使うと、複数の値を簡単にやり取りすることができます。
複数の値を受け取るには関数 call-with-value を使います。
(call-with-values producer consumer)
call-with-values は producer を評価します。producer は引数のない関数で複数の値 (多値) を返します。call-with-value はそれをそのまま cousumer に渡して評価します。その結果が call-with-values の返り値となります。
複数の値を返すには関数 values を使います。
values args ...
values は複数個の引数を多値として返します。簡単な例を示しましょう。
gosh> (values 1 2 3) 1 2 3 gosh> (call-with-values (lambda () (values 1 2 3)) list) (1 2 3)
(values 1 2 3) は 3 つの値 1, 2, 3 を返します。call-with-values は受け取った多値を list に渡すので、(list 1 2 3) が評価されて (1 2 3) が返り値となります。
もう一つ簡単な例題として、SRFI-1 に用意されている関数 partition を作ってみましょう。
partition pred ls
partition はリスト ls を述語 pred で二分割し、pred を満たす要素のリストと、pred を満たさない要素のリストの 2 つを多値として返します。プログラムは次のようになります。
リスト : リストの分割 (1)
(define (partition pred ls)
(if (null? ls)
(values '() '())
(call-with-values
(lambda ()
(partition pred (cdr ls)))
(lambda (a b)
(if (pred (car ls))
(values (cons (car ls) a) b)
(values a (cons (car ls) b)))))))
引数 ls が空リストの場合は values で空リストを 2 つ返します。そうでなければ、call-with-values の最初のラムダ式で partition を再帰呼び出しし、2 番目のラムダ式の引数 a, b で多値を受け取ります。(pred (car ls)) が真の場合、(car ls) を a の先頭に追加し、そうでなければ b の先頭に追加します。あとは values で 2 つのリストを返すだけです。
簡単な実行例を示します。
gosh> (partition even? '(1 2 3 4 5 6)) (2 4 6) (1 3 5) gosh> (partition odd? '(1 2 3 4 5 6)) (1 3 5) (2 4 6)
このように、多値の操作は multiple-value-bind と values を使って行うことができます。このほかにも、便利な関数やマクロがあるので紹介しましょう。
(receive variables mv-expr body ...)
receive (SRFI-8) は多値を受け取ります。variables はシンボルのリストで、mv-expr は多値を返す S 式です。mv-expr が返す多値を variables のシンボルに束縛し、body 以降の S 式を評価します。variables はドットリストでもかまいません。余分な引数はリストに格納されて最後の引数に渡されます。
Gauche は標準で receive を使うことができます。簡単な例を示しましょう。
gosh> (receive (a b c) (values 1 2 3) (list a b c)) (1 2 3) gosh> (receive (a b . c) (values 1 2 3 4 5 6) (list a b c)) (1 2 (3 4 5 6)) gosh> (receive a (values 1 2 3 4 5 6) (list a)) ((1 2 3 4 5 6))
receive を使うと、リストを分割する partition は次のようになります。
リスト : リストの分割 (2)
(define (partition1 pred ls)
(if (null? ls)
(values '() '())
(receive (a b) (partition1 pred (cdr ls))
(if (pred (car ls))
(values (cons (car ls) a) b)
(values a (cons (car ls) b))))))
partition1 を再帰呼び出しするとき、receieve で多値を受け取って変数 a, b にセットするだけです。call-with-values よりも使いやすいと思います。
SRFI-11 には同様の機能を持つマクロ let-values, let*-values があります。
(let-values ((variables mv-expr) ...) body ...) (let*-values ((variables mv-expr) ...) body ...)
variables は receive と同くシンボルのリストで、mv-expr は多値を返す関数です。let-values と let*-values は let と let* の関係と同じです。mv-expr が返す多値を variables のシンボルに束縛し、body 以降の S 式を評価します。Gauche で let-values と let*-values を利用する場合は use で srfi-11 をロードしてください。簡単な使用例を示します。
gosh> (use srfi-11) #<undef> gosh> (let-values (((a b) (values 1 2)) ((c d) (values 3 4))) (list a b c d)) (1 2 3 4) gosh> (let*-values (((a b) (values 1 2)) ((c d) (values a b))) (list a b c d)) (1 2 1 2)
let-values を使うと、リストを分割する parititon は次のようになります。
リスト : リストの分割 (2)
(define (partition2 pred ls)
(if (null? ls)
(values '() '())
(let-values (((a b) (partition2 pred (cdr ls))))
(if (pred (car ls))
(values (cons (car ls) a) b)
(values a (cons (car ls) b))))))
define-values は多値の define バージョンで、set!-values は多値の set! バージョンです。
(define-values variables mv-expr) (set!-values variables mv-expr)
varibales はシンボルのリストですが、ドットリストは受け付けないので注意してください。mv-expr は多値を返す関数です。簡単な使用例を示しましょう。
gosh> (define-values (a b) (values 1 2)) #<undef> gosh> a 1 gosh> b 2 gosh> (set!-values (a b) (values 10 20)) #<undef> gosh> a 10 gosh> b 20
多値の中から一つだけ値を取得したい場合は values-ref を使います。
(values-ref mv-expr n)
mv-expr は多値を返す関数で、values-ref は多値の n 番目の値を返します。n は 0 から数えます。簡単な実行例を示します。
gosh> (values-ref (values 1 2 3) 0) 1 gosh> (values-ref (values 1 2 3) 1) 2 gosh> (values-ref (values 1 2 3) 2) 3
最後に簡単な例題として「クイックソート (quick sort) 」を取り上げます。ソートは昔から研究されている分野で、優秀なアルゴリズムが確立しています。その中でもクイックソートは高速なアルゴリズムとして有名です。
クイックソートはある値を基準にして、要素をそれより大きいものと小さいものの 2 つに分割していくことでソートを行います。基準になる値のことを「枢軸 (pivot) 」といいます。枢軸は要素の中から適当な値を選んでいいのですが、リストの場合は任意の要素を簡単に選ぶことができません。この場合、いちばん簡単に求めることができる先頭の要素を枢軸とします。
リストを 2 つに分けたら、それらを同様にソートします。これは、再帰を使えば簡単に実現できます。その結果を枢軸を挟んで結合します。これを図に表すと次のようになります。
5 3 7 6 9 8 1 2 4
5 を枢軸に分割
(3 1 2 4) 5 (7 6 9 8)
3を枢軸に分割 7を枢軸に分割
(1 2) 3 (4) | 5 | (6) 7 (9 8)
・・・分割を繰り返していく・・・
図 : クイックソート
このようにリストを分割していくと、最後は空リストになります。ここが再帰の停止条件になります。あとは分割したリストを結合していけばいいわけです。プログラムは次のようになります。
リスト : クイックソート
(define (quick-sort f ls)
(if (null? ls)
'()
(let ((p (car ls)))
(receive (a b) (partition (lambda (x) (f x p)) (cdr ls))
(append (quick-sort f a)
(cons p (quick-sort f b)))))))
最初に ls が空リストかチェックします。これが再帰呼び出しの停止条件になります。そうでなければ、リストを分割してソートを行います。リストの先頭要素を取り出して変数 p にセットします。これが枢軸となります。
リストの分割は関数 partition で行います。partition は x を基準にリストを 2 つに分割し、それらのリストを多値で返します。要素の大小関係は述語 pred で判定します。これを receive で受け取り、変数 a, b にセットします。リスト a が枢軸よりも小さな要素を集めたもので、リスト b が枢軸以上の要素を集めたものです。そして、quick-sort を再帰呼び出しして、リスト a, b をソートします。あとは、その結果を枢軸 p を挟んで結合すればいいわけです。
それでは、簡単な実行例を示しましょう。
gosh> (quick-sort < '(5 6 4 7 3 8 2 9 1)) (1 2 3 4 5 6 7 8 9) gosh> (quick-sort > '(5 6 4 7 3 8 2 9 1)) (9 8 7 6 5 4 3 2 1)
正常に動作していますね。
クイックソートの実行時間は、データ数を N とすると平均して N * log2 N に比例します。ところが、枢軸の選び方によっては、最悪で N の 2 乗に比例するところまで劣化します。たとえば、リストの先頭要素を枢軸として選ぶ場合、リストの要素が昇順または降順に並んでいると最悪の結果になります。
このため、クイックソートをプログラムする場合、枢軸の選び方を工夫するのが一般的です。たとえば、データの中からいくつかの要素を選び、その中で中間の値を持つ要素を枢軸に選びます。たくさんの要素を選ぶとそれだけ最悪の枢軸を選ぶ危険性は減少しますが、中間の値を選ぶのに時間がかかってしまいます。実際には、3 つから 5 つの要素を選んで、その中で中間の値を枢軸とする場合が多いようです。
ただし、この改良方法はリストには不向きであることに注意してください。リストはデータ数が多くなるほど、後ろのデータを取り出すのに時間がかかるようになります。先頭から 3 つのデータを取り出して枢軸を選んだとしても、降順または昇順に並んだデータには効果が無いのは明らかです。このため、リストのソートはクイックソートよりも「マージソート (merge sort) 」の方が適しているといわれています。
多値と同じような動作は「継続渡しスタイル (CPS) 」でも実現することができます。CPS についての詳しいは説明は、拙作のページ 継続と継続渡しスタイル をお読みください。
今までは「継続」に渡す引数をひとつに限定していましたが、これを複数の引数を渡すように拡張します。たとえば、リストを分割する partition を CPS でプログラムすると次のようになります。
リスト : リストの分割 (CPS 版)
(define (partition/cps pred ls cont)
(if (null? ls)
(cont '() '())
(partition/cps
pred
(cdr ls)
(lambda (xs ys)
(if (pred (car ls))
(cont (cons (car ls) xs) ys)
(cont xs (cons (car ls) ys)))))))
partition/cps の引数 cont が継続を表します。cont は 2 つの引数を受け取ります。ls が空リストの場合は cont に 2 つの空リストを渡します。parition/cps は継続 (ラムダ式) の引数 xs, ys に 2 つのリストを渡します。この中で ls の先頭要素に述語 pred を適用して、真ならば xs の先頭に要素を追加し、そうでなければ ys の先頭に追加します。最後に、2 つのリストを cont に渡して呼び出すだけです。
簡単な実行例を示します。
gosh> (partition/cps even? '(1 2 3 4 5 6 7 8) (lambda (a b) (list a b))) ((2 4 6 8) (1 3 5 7))
partition/cps を使ったクイックソートは次のようになります。
リスト : クイックソート (CPS 版)
(define (quick-sort f ls)
(if (null? ls)
'()
(let ((p (car ls)))
(partition/cps
(lambda (x) (f x p))
(cdr ls)
(lambda (a b)
(append (quick-sort f a)
(cons p (quick-sort f b))))))))
partition/cps に渡す継続 (ラムダ式) で 2 つのリストを受け取り、この中で quick-sort を再帰呼び出しします。そして、その結果を枢軸 p を挟んで append で結合すればいいわけです。
簡単な実行例を示します。
gosh> (quick-sort < '(5 6 4 7 3 8 2 9 1 10)) (1 2 3 4 5 6 7 8 9 10)
Scheme の多値は R5RS から導入された比較的新しい機能です。多値は Scheme の「継続 (continuation) 」を使って実装されています。通常、継続に渡す引数はひとつだけなのですが、call-with-values のもとで生成された継続に限り、任意の数の引数を渡すことができます。R5RS は values を次のように定義しています。
リスト : values の定義 (R5RS)
(define (values . things)
(call-with-current-continuation
(lambda (cont) (apply cont things))))
call/cc で取り出した継続 cont に複数の値を渡して呼び出しているだけです。この定義からもわかるように、(values) とすると 0 個の引数を継続に渡すことができます。簡単な例を示します。
gosh> (list) () gosh> (call-with-values (lambda () (values)) list) ()
ただし、引数をひとつ受け取る継続に 0 または 2 個以上の引数を渡した場合の動作は R5RS に規定されていません。処理系依存の動作になります。Gauche の場合、引数が 0 個のときは #<undef> が渡され、2 個以上のときは最初の要素が渡されます。
簡単な例を示しましょう。
gosh> (define a #f) a gosh> (display (call/cc (lambda (k) (set! a k) 1))) 1#<undef> gosh> (a 2) 2#<undef> gosh> (a 1 2 3) 1#<undef> gosh> (a) #<undef>#<undef>
display の引数を評価するときの継続を取り出して変数 a にセットします。これは引数をひとつ受け取る継続です。(a 2) を評価すると、2 が display に渡されて 2 が表示されます。(a 1 2 3) を評価すると、最初の引数 1 が display に渡されます。(a) を評価すると #<undef> が渡されます。ただし、処理系によって動作が異なる可能性があります。引数の個数が合わない場合、エラーを送出する処理系があるかもしれません。ご注意くださいませ。
リストの中から要素を一つ選ぶ処理を考えます。たとえば、(list-ref ls n) はリスト ls の n 番目の要素を取り出しますが、選ぶ要素を引数 n で指定する必要があります。これに対して、特別な指定をしないで無作為に要素を選ぶことを考えます。このような選択を「非決定的選択」といいます。
ここで、非決定的選択は問題を解くのに都合のいい選択が行われると仮定します。つまり、複数の選択肢の中で解に導くものがいくつか存在するならば、そのうちの一つを選択するのです。たとえば、迷路で分かれ道にきた場合、その中から出口につながる道を一つ選ぶわけです。このような非決定的選択を含む処理 (計算) を「非決定性計算」とか「非決定性」といいます。
このような都合のいい処理を現在のコンピュータで実現することは不可能ですが、バックトラックを使って近似的に実現することは可能です。つまり、ある要素を選んで条件を満たさない場合は、バックトラックして異なる要素を選択すればいいわけです。今回は 独習 Scheme 三週間 Chapter 14 非決定性 を参考に、非決定性計算を行う関数 amb を作ってみましょう。
関数 amb は 0 個以上の引数を受け取り、その中から一つを選んで返します。次の例を見てください。
(amb 1 2 3) => 1, 2, 3 のどれか 1 つを返す (amb) => バックトラックして残りの 2 つのうちの 1 つを返す (amb) => バックトラックして最後の 1 つを返す (amb) => これ以上バックトラックできないのでエラー
amb は 1 個以上の引数が与えられた場合、その中の 1 つを選んで返します。引数がない場合、バックトラックして次の要素を選びます。今回は先頭から順番に引数を選んでいくことにしましょう。
amb は要素を選ぶだけの単純な動作ですが、複数の amb を組み合わせると複雑な動作が可能になります。リスト (1 2 3) と (4 5 6) から要素を一つずつ取り出して、その組を求める処理は次のようになります。
(list (amb 1 2 3) (amb 4 5 6)) => (1 4) (amb) => (1 5) (amb) => (1 6) (amb) => (2 4) (amb) => (2 5) (amb) => (2 6) (amb) => (3 4) (amb) => (3 5) (amb) => (3 6) (amb) => エラー
最初の amb で 1 を選び、次の amb で 4 が選ばれるので、最初の値は (1 4) になります。次に、amb を評価すると、2 番目の amb がバックトラックして、次の要素 5 を選びます。したがって、返り値は (1 5) になります。そして、その次の返り値は (1 6) になります。
2 番目の amb で要素がなくなると、最初の amb にバックトラックします。すると、次の要素 2 を選び、2 番目の amb を評価します。ここで 2 番目の amb は新しく評価されることに注意してください。引数 4, 5, 6 を順番に選んでいくので、返り値は (2 4) になります。あとはバックトラックするたびに組が生成され、全ての組み合わせを求めることができます。
ただし、amb を関数として定義すると、次の場合は正常に動作しません。
(amb (amb) 1) => 1 を返すはずがエラーになる
この場合、引数の (amb) が失敗しても次の要素 1 を選ぶはずなのですが、Scheme の関数は先に引数 (amb) を評価するのでエラーになるのです。したがって、amb はマクロで定義する必要があります。
いきなりマクロを作るのは大変なので、まず最初に関数版 amb から作りましょう。プログラムは次のようになります。
リスト : 非決定性 amb (関数版)
; バックトラックするときの継続を格納する
(define *amb-fail* #f)
; 初期化
(define (initialize-amb-fail)
(set! *amb-fail*
(lambda () (error "amb tree exhausted"))))
; 非決定性 amb (関数版)
(define (amb . args)
(if (null? args)
(*amb-fail*)
(let ((prev-fail *amb-fail*))
(call/cc
(lambda (cont-s)
(for-each
(lambda (x)
(call/cc
(lambda (cont-f)
(set! *amb-fail*
(lambda ()
(set! *amb-fail* prev-fail)
(cont-f #f)))
(cont-s x))))
args)
(prev-fail))))))
*amb-fail* はバックトラックするときの継続を格納します。関数 initialize-amb-fail は *amb-fail* を初期化します。これは error でエラー "amb tree exhausted" を送出するだけです。関数 amb は引数のリスト args の要素を先頭から順番に取り出していきます。この処理は拙作のページ 継続と継続渡しスタイル で作成したイテレータとよく似ています。
最初に args が空リストかチェックします。そうであれば、*amb-fail* に格納されている継続を実行します。引数がある場合は、先頭から順番に取り出していきます。まず、*amb-fail* に格納されている継続を局所変数 prev-fail に保存します。次に、call/cc で要素を返すための継続を取り出して cont-s に渡します。そして、for-each で args の要素を順番にアクセスします。
ラムダ式の中でバックトラックするときの継続を取り出して cont-f に渡します。そして、*amb-fail* に cont-f を呼び出す処理をセットします。この処理の中で、prev-fail に保存しておいた継続を *amb-fail* に戻してから、cont-f を呼び出してバックトラックするようにします。最後に (cont-s x) で要素 x を返します。
これで、(amb) でバックトラックすると for-each の処理に戻るので、要素を一つずつ取り出すことができます。for-each が終了したら prev-fail を呼び出すことに注意してください。これで、以前に実行した amb にバックトラックすることができます。なお、このときの prev-fail と *amb-fail* は同じ値なので、(*amb-fail*) を評価してもかまいません。
それでは簡単な実行例を示しましょう。
gosh> (initialize-amb-fail) #<closure (initialize-amb-fail initialize-amb-fail)> gosh> (amb 1 2 3) 1 gosh> (amb) 2 gosh> (amb) 3 gosh> (amb) *** ERROR: amb tree exhausted gosh> (list (amb 1 2) (amb 3 4)) (1 3) gosh> (amb) (1 4) gosh> (amb) (2 3) gosh> (amb) (2 4) gosh> (amb) *** ERROR: amb tree exhausted gosh>
もう一つ簡単な例として、順列を生成するプログラムを作ってみましょう。次のリストを見てください。
リスト : 順列の生成
; 条件 pred を満たさない場合はバックトラックする
(define (assert pred)
(if (not pred) (amb)))
; ls から n 個を取り出す順列
(define (perm n ls)
(let loop ((n n) (a '()))
(if (zero? n)
(reverse a)
(let ((x (apply amb ls)))
(assert (not (member x a)))
(loop (- n 1) (cons x a))))))
assert は pred が偽の場合は (amb) を評価してバックトラックします。amb を使うと順列を生成する関数 perm は簡単に実現できます。amb でリストの要素を 1 つ選び、それが順列 a に含まれていないことを assert で確認します。同じ要素が含まれていれば、バックトラックして異なる要素を選びます。n 個の要素を選んだら reverse でリスト a を反転した値を返します。
それでは実行例を示します。
gosh> (perm 4 '(a b c d)) (a b c d) gosh> (amb) (a b d c) gosh> (amb) (a c b d) gosh> (amb) (a c d b) gosh> (amb) (a d b c) gosh> (amb) (a d c b)
このように、バックトラックするたびに順列を一つずつ生成することができます。
非決定性のプログラムはバックトラックすることで全ての解を求めることができます。このとき、見つけた解をリストに格納して返す関数があると便利です。次のリストを見てください。
リスト : 見つけた解をリストに格納して返す
(define (bag-of func)
(let ((prev-fail *amb-fail*)
(result '()))
(if (call/cc
(lambda (cont)
(set! *amb-fail* (lambda () (cont #f)))
(push! result (func))
(cont #t)))
(*amb-fail*))
(set! *amb-fail* prev-fail)
(reverse! result)))
関数 bag-of は引数 func を実行して、その結果をリストに格納して返します。func は非決定性計算を行う関数です。最初に *amb-fail* を局所変数 prev-fail に保存します。func の返り値は局所変数 result に格納します。次に、call/cc で脱出先の継続 cont を取り出して、*amb-fail* に (lambda () (cont #f)) をセットします。そして、関数 func を評価して、その返り値を result の先頭に追加します。
(cont #t) を評価すると、call/cc の返り値が #t となり、if の then 節が評価されるので、(*amb-fail*) が実行されます。func の処理にバックトラックして、解が見つかればその値を返します。つまり、解が存在する限り次の処理が繰り返されます。
(push! result (func)) -> (cont #t) -> (*amb-fail*)
これで複数の解を result に格納することができます。func で解が見つからない場合、最初に *amb-fail* にセットした (lambda () (cont #f)) が実行されます。その結果、if 条件が偽と判定され、バックトラックを終了します。*amb-fail* を元の値に戻し、result を reverse! で反転して返します。
簡単な実行例を示しましょう。
gosh> (initialize-amb-fail) #<closure (initialize-amb-fail initialize-amb-fail)> gosh> (bag-of (lambda () (amb 1 2 3 4))) (1 2 3 4) gosh> (bag-of (lambda () (list (amb 1 2 3) (amb 4 5 6)))) ((1 4) (1 5) (1 6) (2 4) (2 5) (2 6) (3 4) (3 5) (3 6)) gosh> (bag-of (lambda () (perm 3 '(a b c)))) ((a b c) (a c b) (b a c) (b c a) (c a b) (c b a))
このように bag-of を使って全ての解を求めることができます。
それでは簡単な例題として論理パズルを解いてみましょう。
３人の友達が、あるプログラミング競技会で１位、２位、３位になった。この３人は、名前も、好きなスポーツも、国籍も異なる。Michael はバスケットが好きで、アメリカ人よりも上位であった。イスラエル人の Simon はテニスをする者よりも上位であった。クリケットをするものが１位であった。誰がオーストラリア人か？ Richard はどのようなスポーツをするか？
簡単な論理パズルなので、プログラムを作る前に考えてみてください。
最初にデータ構造とアクセス関数を定義します。データはリストで表します。
(名前 順位 国籍 スポーツ)
このデータを amb で作成します。次のリストを見てください。
リスト : データとアクセス関数の定義
(use srfi-1)
; データの生成
(define (make-data name)
(list name
(amb 1 2 3)
(amb 'US 'IL 'AU)
(amb 'basket 'cricket 'tennis)))
; アクセス関数
(define (get-rank x) (second x))
(define (get-nation x) (third x))
(define (get-sports x) (fourth x))
amb で順位 (1, 2, 3)、国籍 (US, IL, AU)、スポーツ (basket, cricket, tennis) の中から要素を一つ選びます。バックトラックすると異なる要素が選ばれて、新しいデータが生成されます。
次は問題を解くための補助関数を作ります。
リスト : 補助関数の定義
; 国籍が x の人を探す
(define (find-nation x . ls)
(find (lambda (a) (eq? x (get-nation a))) ls))
; スポーツ x が好きな人を探す
(define (find-sports x . ls)
(find (lambda (a) (eq? x (get-sports a))) ls))
; 重複した要素が有るか
(define (duplicate? pred ls)
(cond ((null? ls) #f)
((find (lambda (x) (pred (car ls) x)) (cdr ls)) #t)
(else (duplicate? pred (cdr ls)))))
; 要素が異なっているか
(define (check? . ls)
(duplicate? (lambda (x y) (any eqv? (cdr x) (cdr y))) ls))
find-nation はリスト ls の中から国籍が x の要素を返します。find-sports は好きなスポーツが x の要素を返します。duplicate? はリスト ls に重複した要素があれば #t を返します。要素が全て異なる場合は #f を返します。引数 pred には要素が等しいかチェックする述語を渡します。
check? は duplicate? を呼び出して、重複した要素が有れば #t を返します。ラムダ式の引数 x, y にはデータ (名前 順位 国籍 スポーツ) が渡されます。名前以外で等しい要素があれば #t を返します。この処理は SRFI-1 の関数 any を使うと簡単です。
any pred list1 list2 ...
any は高階関数で、リストの要素に pred を適用し、返り値が真となる要素があればその値を返します。すべての要素が偽となる場合は #f を返します。順位は数値なので eqv? で比較しています。
論理パズルの解法プログラムは次のようになります。
リスト : 論理パズルの解法
(define (puzzle)
(let ((m (make-data 'Michael))
(s (make-data 'Simon))
(r (make-data 'Richard)))
(assert (not (check? m s r)))
(assert (eq? (get-sports m) 'basket))
(assert (not (eq? (get-nation m) 'US)))
(assert (eq? (get-nation s) 'IL))
(assert (< (get-rank m) (get-rank (find-nation 'US m s r))))
(assert (< (get-rank s) (get-rank (find-sports 'tennis m s r))))
(assert (= (get-rank (find-sports 'cricket m s r)) 1))
(list m s r)))
最初に make-data でデータを作成し、局所変数 m, s, r にセットします。そして、check? で順位、国籍、スポーツで要素が重複していないかチェックします。あとは問題の条件を assert でチェックしていくだけです。
条件を満たさない場合はバックトラックして新しいデータを生成します。最後に、見つけた解を出力します。とても簡単ですね。実行結果は次のようになります。
gosh> (initialize-amb-fail) #<closure (initialize-amb-fail initialize-amb-fail)> gosh> (puzzle) ((Michael 2 AU basket) (Simon 1 IL cricket) (Richard 3 US tennis)) gosh> (amb) *** ERROR: amb tree exhausted
解は 1 通りで、１位が Simon, ２位が Michael, ３位が Richard になります。ちなみに、最後の条件がない場合は 2 通りの解が出力されます。興味のある方は試してみてください。
それではマクロ版 amb を作りましょう。次のリストを見てください。
リスト : 非決定性 amb (マクロ版)
; バックトラックするときの継続を格納する
(define *amb-fail* #f)
; 初期化
(define (initialize-amb-fail)
(set! *amb-fail*
(lambda () (error "amb tree exhausted"))))
; 非決定性 amb (マクロ版)
(define-syntax amb
(syntax-rules ()
((_) (*amb-fail*))
((_ a) a)
((_ a ...)
(let((prev-fail *amb-fail*))
(call/cc
(lambda (cont-s)
(call/cc
(lambda (cont-f)
(set! *amb-fail*
(lambda ()
(set! *amb-fail* prev-fail)
(cont-f #f)))
(cont-s a)))
...
(prev-fail)))))))
引数がない場合は *amb-fail* に格納されている継続を実行します。引数が一つの場合はその評価結果を返します。ここまでは簡単ですね。引数が複数ある場合、関数版では for-each を使って実現しましたが、マクロ版では引数の数だけマクロ展開することにします。
引数 a は S 式 (call/cc (lambda (cont-f) ... (cont-s a))) でマクロ展開されます。このあとで省略子 ... を指定すると、残りの引数にもこの S 式が適用されてマクロ展開されます。たとえば、引数が 3 つある場合、S 式 (call/cc (lambda (cont-f) ... (cont-s x))) が 3 つマクロ展開され、(call/cc ...) (call/cc ...) (call/cc ...) となるわけです。ここで (cont-s x) の x は与えられた引数になります。
したがって、最初の引数を返したあとの継続は 2 番目の (call/cc ...) になり、2 番目の引数を返したあとの継続は 3 番目の (call/cc ...) になります。そして、最後の引数を返したあとの継続が (prev-fail) になります。この継続を実行すると以前に実行した amb の処理にバックトラックします。
それでは簡単な実行例を示しましょう。
gosh> (initialize-amb-fail) #<closure (initialize-amb-fail initialize-amb-fail)> gosh> (amb 1 2 3) 1 gosh> (amb) 2 gosh> (amb) 3 gosh> (amb) *** ERROR: amb tree exhausted gosh> (list (amb 'a 'b) (amb 'c 'd)) (a c) gosh> (amb) (a d) gosh> (amb) (b c) gosh> (amb) (b d) gosh> (amb) *** ERROR: amb tree exhausted Stack Trace: gosh> (amb (amb) 1) 1 gosh> (amb) *** ERROR: amb tree exhausted gosh> (amb 1 (amb) 2) 1 gosh> (amb) 2 gosh> (amb) *** ERROR: amb tree exhausted
amb はマクロなので (amb (amb) 1) も正常に動作します。
ところで、bag-of もマクロにすると便利です。プログラムは次のようになります。
リスト : マクロ版 bag-of
(define-syntax bag-of
(syntax-rules ()
((_ e)
(let ((prev-fail *amb-fail*)
(results '()))
(if (call/cc
(lambda (cont)
(set! *amb-fail* (lambda () (cont #f)))
(push! results e)
(cont #t)))
(*amb-fail*))
(set! *amb-fail* prev-fail)
(reverse! results)))))
関数 bag-of をマクロ定義しただけなので、とくに難しいところはないと思います。簡単な実行例を示します。
gosh> (initialize-amb-fail) #<closure (initialize-amb-fail initialize-amb-fail)> gosh> (bag-of (list (amb 1 2 3) (amb 1 2 3))) ((1 1) (1 2) (1 3) (2 1) (2 2) (2 3) (3 1) (3 2) (3 3))
最後に地図の配色問題を解いてみましょう。今回は、下図に示す簡単な地図を 4 色で塗り分けてみます。
┌─────────┐
│ ａ │
├──┬───┬──┤
│ ｂ │ ｃ │ ｄ │
├──┴─┬─┴──┤
│ ｅ │ ｆ │
└────┴────┘
図：簡単な地図
なお、地図は下記文献 (276頁) より引用しました。
プログラムは次のようになります。
リスト : 地図の配色問題
(define (color-map)
(define regions '(a b c d e f))
(define adjacent '((a b c d) (b a c e) (c a b d e f)
(d a c f) (e b c f) (f c d e)))
(define (get-color p ls) (cdr (assoc p ls)))
(define (same-color? region ls)
(let ((color (get-color region ls)))
(find (lambda (x) (eq? (get-color x ls) color))
(cdr (assoc region adjacent)))))
;
(let ((m (map (lambda (x) (cons x (amb 'blue 'green 'red 'yellow))) regions)))
(for-each
(lambda (x)
(assert (not (same-color? x m))))
regions)
m))
地域と色の対応は連想リストで表します。そして、map で連想リストを作るときに、amb で色を選んでセットするところがポイントです。そして、隣り合った地域で同じ色が使われていないか関数 same-color? でチェックします。同じ色が使われていたら、バックトラックして異なる色を選び直します。最後に連想リストを返します。
実行結果を示します。
gosh> (initialize-amb-fail) #<closure (initialize-amb-fail initialize-amb-fail)> gosh> (color-map) ((a . blue) (b . green) (c . red) (d . green) (e . blue) (f . yellow))
┌─────────┐
│ ■ │
├──┬───┬──┤
│ ■ │ ■ │ ■ │
├──┴─┬─┴──┤
│ ■ │ ■ │
└────┴────┘
図 : 解答
このように amb を使うと問題を簡単に解くことができますが、生成されるデータ数が多くなると実行時間が極端に遅くなります。ようするに「生成検定法」と同じなので、なるべく無駄なデータを生成しないように工夫する必要があります。ご注意くださいませ。