リストの中から要素をひとつ選ぶ処理を考えます。たとえば、(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 から作りましょう。プログラムは次のようになります。なお、今回のプログラムは拙作のライブラリ (mylib list) "abcscm25.html#list1" を使います。
リスト : 非決定性 amb (関数版)
(import (scheme base) (mylib list))
;;; バックトラックするときの継続を格納する
(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[r7rs.user]> (initialize-amb-fail) #<closure ((initialize-amb-fail initialize-amb-fail))> gosh[r7rs.user]> (amb 1 2 3) 1 gosh[r7rs.user]> (amb) 2 gosh[r7rs.user]> (amb) 3 gosh[r7rs.user]> (amb) *** ERROR: amb tree exhausted gosh[r7rs.user]> (list (amb 1 2) (amb 3 4)) (1 3) gosh[r7rs.user]> (amb) (1 4) gosh[r7rs.user]> (amb) (2 3) gosh[r7rs.user]> (amb) (2 4) gosh[r7rs.user]> (amb) *** ERROR: amb tree exhausted
もう一つ簡単な例として、順列を生成するプログラムを作ってみましょう。次のリストを見てください。
リスト : 順列の生成
;;; 条件 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[r7rs.user]> (initialize-amb-fail) #<closure ((initialize-amb-fail initialize-amb-fail))> gosh[r7rs.user]> (perm 4 '(a b c d)) (a b c d) gosh[r7rs.user]> (amb) (a b d c) gosh[r7rs.user]> (amb) (a c b d) gosh[r7rs.user]> (amb) (a c d b) gosh[r7rs.user]> (amb) (a d b c) gosh[r7rs.user]> (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)))
(set! result (cons (func) result))
(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 の処理にバックトラックして、解が見つかればその値を返します。つまり、解が存在する限り次の処理が繰り返されます。
(set! result (cons (func) result)) -> (cont #t) -> (*amb-fail*)
これで複数の解を result に格納することができます。func で解が見つからない場合、最初に *amb-fail* にセットした (lambda () (cont #f)) が実行されます。その結果、if 条件が偽と判定され、バックトラックを終了します。*amb-fail* を元の値に戻し、result を reverse! で反転して返します。
簡単な実行例を示しましょう。
gosh[r7rs.user]> (initialize-amb-fail) #lt;closure ((initialize-amb-fail initialize-amb-fail))> gosh[r7rs.user]> (bag-of (lambda () (amb 1 2 3 4))) (1 2 3 4) gosh[r7rs.user]> (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[r7rs.user]> (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 で作成します。次のリストを見てください。
リスト : データとアクセス関数の定義
;;; データの生成
(define (make-data name)
(list name
(amb 1 2 3)
(amb 'US 'IL 'AU)
(amb 'basket 'cricket 'tennis)))
;;; アクセス関数
(define (get-rank x) (list-ref x 1))
(define (get-nation x) (list-ref x 2))
(define (get-sports x) (list-ref x 3))
amb で順位 (1, 2, 3)、国籍 (US, IL, AU)、スポーツ (basket, cricket, tennis) の中から要素を一つ選びます。バックトラックすると異なる要素が選ばれて、新しいデータが生成されます。
次は問題を解くための補助関数を作ります。
リスト : 補助関数の定義 ;;; 国籍が x の人を探す (define (find-nation x . ls) (find-if (lambda (a) (eq? x (get-nation a))) ls)) ;;; スポーツ x が好きな人を探す (define (find-sports x . ls) (find-if (lambda (a) (eq? x (get-sports a))) ls)) ;;; 要素が異なっているか (define (check? . ls) (duplicates? (lambda (x y) (any eqv? (cdr x) (cdr y))) ls))
find-nation はリスト ls の中から国籍が x の要素を返します。find-sports は好きなスポーツが x の要素を返します。関数 find-if は第 1 引数の述語を満たす要素を線形探索します。duplicates? は重複要素があるかチェックします。どちらの関数も拙作のライブラリ (mylib list) に定義されています。
check? は duplicates? を呼び出して、重複した要素が有れば #t を返します。ラムダ式の引数 x, y にはデータ (名前 順位 国籍 スポーツ) が渡されます。名前以外で等しい要素があれば #t を返します。この処理は関数 any を使うと簡単です。any も (mylib list) に定義されています。
論理パズルの解法プログラムは次のようになります。
リスト : 論理パズルの解法
(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[r7rs.user]> (initialize-amb-fail) #<closure ((initialize-amb-fail initialize-amb-fail))> gosh[r7rs.user]> (puzzle) ((Michael 2 AU basket) (Simon 1 IL cricket) (Richard 3 US tennis)) gosh[r7rs.user]> (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[r7rs.user]> (initialize-amb-fail) #<closure ((initialize-amb-fail initialize-amb-fail))> gosh[r7rs.user]> (amb 1 2 3) 1 gosh[r7rs.user]> (amb) 2 gosh[r7rs.user]> (amb) 3 gosh[r7rs.user]> (amb) *** ERROR: amb tree exhausted gosh[r7rs.user]> (list (amb 'a 'b) (amb 'c 'd)) (a c) gosh[r7rs.user]> (amb) (a d) gosh[r7rs.user]> (amb) (b c) gosh[r7rs.user]> (amb) (b d) gosh[r7rs.user]> (amb) *** ERROR: amb tree exhausted gosh[r7rs.user]> (amb 1 (amb) 2) 1 gosh[r7rs.user]> (amb) 2 gosh[r7rs.user]> (amb) *** ERROR: amb tree exhausted
amb はマクロなので (amb (amb) 1) も正常に動作します。
ところで、bag-of もマクロにすると便利です。プログラムは次のようになります。
リスト : マクロ版 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)))
(set! results (cons e results))
(cont #t)))
(*amb-fail*))
(set! *amb-fail* prev-fail)
(reverse! results)))))
関数 bag-of をマクロ定義しただけなので、とくに難しいところはないと思います。簡単な実行例を示します。
gosh[r7rs.user]> (initialize-amb-fail) #<closure ((initialize-amb-fail initialize-amb-fail))> gosh[r7rs.user]> (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-if (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[r7rs.user]> (initialize-amb-fail) #<closure ((initialize-amb-fail initialize-amb-fail))> gosh[r7rs.user]> (color-map) ((a . blue) (b . green) (c . red) (d . green) (e . blue) (f . yellow))
┌─────────┐
│ ■ │
├──┬───┬──┤
│ ■ │ ■ │ ■ │
├──┴─┬─┴──┤
│ ■ │ ■ │
└────┴────┘
図 : 解答
このように amb を使うと問題を簡単に解くことができますが、生成されるデータ数が多くなると実行時間が極端に遅くなります。ようするに「生成検定法」と同じなので、なるべく無駄なデータを生成しないように工夫する必要があります。ご注意くださいませ。