micro Scheme の続きです。今回は継続の例題として「非決定性計算」を行う関数 amb を作りましょう。
リストの中から要素を一つ選ぶ処理を考えます。たとえば、(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 を作る前に、ライブラリ lib.scm に必要となる関数を追加します。まずは最初に高階関数 for-each を追加します。
for-each func list
for-each は Scheme の仕様書 (R5RS など) に定義されている関数で、引数のリストから順番に要素を取り出して、それを引数 func に渡して評価します。map と違って for-each は func を呼び出すだけであり、func の返り値は捨てられます。for-each は副作用を目的とした関数を呼び出すときに使います。Gauche の場合、for-each の返り値は #<undef> です。
簡単な例を示しましょう。
gosh> (define (foo x) (display x) (newline)) foo gosh> (for-each foo '(1 2 3 4 5)) 1 2 3 4 5 #<undef>
for-each は fold-left を使うと簡単に定義できます。
リスト : for-each の定義
(define for-each
(lambda (f xs)
(fold-left (lambda (a x) (f x) a) '() xs)))
;;; 別解
(define for-each
(lambda (f xs)
(if (null? xs)
'()
(begin (f (car xs)) (for-each f (cdr xs))))))
fold-left に渡すラムダ式の中で (f x) を評価して、累積変数をそのまま返すだけです。micro Scheme の場合、for-each は空リストを返すことにします。また、別解のように再帰定義でも簡単にプログラムすることができます。
次は連想リストを探索する関数を追加します。Scheme の連想リストはドット対を要素とするリストです。ドット対の CAR 部がキーで、CDR 部がデータに対応します。次の図を見てください。
┌───┬───┬───┬──→ データ
│ │ │ │
連想リスト => ((a . b) (c . d) (e . f) (g . h))
│ │ │ │
└───┴───┴───┴──→ キー
図 : 連想リストの構造
上図の場合、a, c, e, g がキーで、b, d, f, h がデータとなります。キーやデータはシンボル以外の S 式でもかまいません。そして、連想リストからデータを探索する関数が assq, assv, assoc です。
assq obj a-list assv obj a-list assoc obj a-list
assoc は member と同様に Lisp の伝統的な関数です。assoc は連想リスト a-list から obj と等しいキーを探します。見つからない場合は false を返します。等値関係のテストは member と同様に、assq が eq? を、assv が eqv? を、assoc が equal? を用います。
簡単な使用例を示しましょう。
gosh> (define z '((a . b) (c . d) (e . f) (g . h))) z gosh> (assoc 'e z) (e . f) gosh> (assoc 'h z) #f
assq, assv, assoc は、見つけたキーのデータを返すのではなく、ドット対を返すことに注意してください。
プログラムは次のようになります。
リスト : 連想リストの探索
(define assq
(lambda (x xs)
(if (null? xs)
false
(if (eq? (caar xs) x)
(car xs)
(assq x (cdr xs))))))
(define assv
(lambda (x xs)
(if (null? xs)
false
(if (eqv? (caar xs) x)
(car xs)
(assv x (cdr xs))))))
(define assoc
(lambda (x xs)
(if (null? xs)
false
(if (equal? (caar xs) x)
(car xs)
(assoc x (cdr xs))))))
再帰定義でリスト xs を順番にたどり、引数 x とキー (caar xs) が等値関係 (eq?, eqv?, equal?) を満たせば要素 (car xs) を返します。とくに難しいところは無いと思います。
それではプログラムを作りましょう。いきなりマクロを作るのは大変なので、関数版 amb から作ります。プログラムは次のようになります。
リスト : 非決定性 amb (関数版)
;;; バックトラックするときの継続を格納する
(define *amb-fail* false)
;;; 初期化
(define initialize-amb-fail
(lambda ()
(set! *amb-fail*
(lambda () (error "amb tree exhausted")))))
;;; 非決定性 amb (関数版)
(define amb
(lambda 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 false)))
(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*) を評価してもかまいません。
それでは簡単な実行例を示しましょう。
Scm> (initialize-amb-fail) <closure> Scm> (amb 1 2 3) 1 Scm> (amb) 2 Scm> (amb) 3 Scm> (amb) ERROR: amb tree exhausted Scm> (initialize-amb-fail) <closure> Scm> (list (amb 1 2) (amb 3 4)) (1 3) Scm> (amb) (1 4) Scm> (amb) (2 3) Scm> (amb) (2 4) Scm> (amb) ERROR: amb tree exhausted
もう一つ簡単な例として、順列を生成するプログラムを作ってみましょう。次のリストを見てください。
リスト : 順列の生成
;;; 条件 pred を満たさない場合はバックトラックする
(define assert
(lambda (pred)
(if (not pred) (amb))))
;;; ls から n 個を取り出す順列
(define perm
(lambda (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 を反転した値を返します。
それでは実行例を示します。
Scm> (perm 4 '(a b c d)) (a b c d) Scm> (amb) (a b d c) Scm> (amb) (a c b d) Scm> (amb) (a c d b) Scm> (amb) (a d b c) Scm> (amb) (a d c b) Scm> (amb) (b a c d) Scm> (amb) (b a d c) Scm> (amb) (b c a d) Scm> (amb) (b c d a)
このように、バックトラックするたびに順列を一つずつ生成することができます。
非決定性のプログラムはバックトラックすることで全ての解を求めることができます。このとき、見つけた解をリストに格納して返す関数があると便利です。次のリストを見てください。
リスト : 見つけた解をリストに格納して返す
(define bag-of
(lambda (func)
(let ((prev-fail *amb-fail*)
(result '()))
(if (call/cc
(lambda (cont)
(set! *amb-fail* (lambda () (cont false)))
(set! result (cons (func) result))
(cont true)))
(*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 false)) をセットします。そして、関数 func を評価して、その返り値を result の先頭に追加します。
(cont true) を評価すると、call/cc の返り値が true となり、if の then 節が評価されるので、(*amb-fail*) が実行されます。func の処理にバックトラックして、解が見つかればその値を返します。つまり、解が存在する限り次の処理が繰り返されます。
(set! result (cons (func) result)) -> (cont true) -> (*amb-fail*)
これで複数の解を result に格納することができます。func で解が見つからない場合、最初に *amb-fail* にセットした (lambda () (cont false)) が実行されます。その結果、if 条件が偽と判定され、バックトラックを終了します。*amb-fail* を元の値に戻し、result を reverse で反転して返します。
簡単な実行例を示しましょう。
Scm> (initialize-amb-fail) <closure> Scm> (bag-of (lambda () (amb 1 2 3 4 5))) (1 2 3 4 5) Scm> (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)) Scm> (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
(lambda (name)
(list name
(amb 1 2 3)
(amb 'US 'IL 'AU)
(amb 'basket 'cricket 'tennis))))
;;; アクセス関数
(define get-rank (lambda (x) (second x)))
(define get-nation (lambda (x) (third x)))
(define get-sports (lambda (x) (fourth x)))
amb で順位 (1, 2, 3)、国籍 (US, IL, AU)、スポーツ (basket, cricket, tennis) の中から要素を一つ選びます。バックトラックすると異なる要素が選ばれて、新しいデータが生成されます。
次は問題を解くための補助関数を作ります。
リスト : 補助関数の定義
;;; 国籍が x の人を探す
(define find-nation
(lambda (x . ls)
(find (lambda (a) (eq? x (get-nation a))) ls)))
;;; スポーツ x が好きな人を探す
(define find-sports
(lambda (x . ls)
(find (lambda (a) (eq? x (get-sports a))) ls)))
;;; 重複した要素が有るか
(define duplicate?
(lambda (pred ls)
(cond ((null? ls) false)
((find (lambda (x) (pred (car ls) x)) (cdr ls)) true)
(else (duplicate? pred (cdr ls))))))
;;; 要素が異なっているか
(define check?
(lambda ls
(duplicate? (lambda (x y) (any eqv? (cdr x) (cdr y))) ls)))
find-nation はリスト ls の中から国籍が x の要素を返します。find-sports は好きなスポーツが x の要素を返します。duplicate? はリスト ls に重複した要素があれば true を返します。要素が全て異なる場合は false を返します。引数 pred には要素が等しいかチェックする述語を渡します。
check? は duplicate? を呼び出して、重複した要素が有れば true を返します。ラムダ式の引数 x, y にはデータ (名前 順位 国籍 スポーツ) が渡されます。名前以外で等しい要素があれば true を返します。
論理パズルの解法プログラムは次のようになります。
リスト : 論理パズルの解法
(define puzzle
(lambda ()
(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 でチェックしていくだけです。
条件を満たさない場合はバックトラックして新しいデータを生成します。最後に、見つけた解を出力します。とても簡単ですね。実行結果は次のようになります。
$ stack exec ghc -- -O mscheme4.hs [1 of 2] Compiling Main ( mscheme4.hs, mscheme4.o ) [2 of 2] Linking mscheme4 $ ./mscheme4 Scm> (load "lib.scm") true Scm> (load "amb0.scm") true Scm> (initialize-amb-fail) <closure> Scm> (puzzle) ((Michael 2 AU basket) (Simon 1 IL cricket) (Richard 3 US tennis)) Scm> (amb) ERROR: amb tree exhausted Scm>
解は 1 通りで、１位が Simon, ２位が Michael, ３位が Richard になります。ちなみに、最後の条件がない場合は 2 通りの解が出力されます。興味のある方は試してみてください。なお、ghci では時間がかかるので、ghc で mscheme4.hs をコンパイルしてください。
次はマクロ版 amb を作りましょう。次のリストを見てください。
リスト : 非決定性 amb (マクロ版)
;;; バックトラックするときの継続を格納する
(define *amb-fail* false)
;;; 初期化
(define initialize-amb-fail
(lambda ()
(set! *amb-fail*
(lambda () (error "amb tree exhausted")))))
;;; 非決定性 amb (マクロ版)
(define-macro amb
(lambda args
`(let ((prev-fail *amb-fail*))
(call/cc
(lambda (cont-s)
,@(map (lambda (x)
`(call/cc
(lambda (cont-f)
(set! *amb-fail*
(lambda ()
(set! *amb-fail* prev-fail)
(cont-f false)))
(cont-s ,x))))
args)
(prev-fail))))))
プログラムは「独習 Scheme 三週間」の "Chapter 14 非決定性" の amb とほとんど同じです。引数が複数ある場合、関数版では for-each を使って実現しましたが、マクロ版では引数の数だけマクロ展開することにします。この処理を ,@(map ... ) で行います。
たとえば、引数が 3 つある場合、S 式 (lambda (x) `(call/cc (lambda (cont-f) ... (cont-s ,x)))) が 3 つマクロ展開され、(call/cc ...) (call/cc ...) (call/cc ...) となるわけです。ここで (cont-s ,x) の x はラムダ式の引数 x を評価した値になります。
したがって、最初の引数を返したあとの継続は 2 番目の (call/cc ...) になり、2 番目の引数を返したあとの継続は 3 番目の (call/cc ...) になります。そして、最後の引数を返したあとの継続が (prev-fail) になります。この継続を実行すると以前に実行した amb の処理にバックトラックします。
引数 args が空リストの場合、map は空リストを返すので、(prev-fail) を評価するだけの処理にマクロ展開されます。したがって、*amb-fail* に格納されている継続を評価することになり、バックトラックすることができます。
それでは簡単な実行例を示しましょう。
Scm> (initialize-amb-fail) <closure> Scm> (amb 1 2 3) 1 Scm> (amb) 2 Scm> (amb) 3 Scm> (amb) ERROR: amb tree exhausted Scm> (initialize-amb-fail) <closure> Scm> (list (amb 'a 'b) (amb 'c 'd)) (a c) Scm> (amb) (a d) Scm> (amb) (b c) Scm> (amb) (b d) Scm> (amb) ERROR: amb tree exhausted Scm> (initialize-amb-fail) <closure> Scm> (amb (amb) 1) 1 Scm> (amb) ERROR: amb tree exhausted Scm> (initialize-amb-fail) <closure> Scm> (amb 1 (amb) 2) 1 Scm> (amb) 2 Scm> (amb) ERROR: amb tree exhausted
amb はマクロなので (amb (amb) 1) も正常に動作します。
ところで、bag-of もマクロにすると便利です。プログラムは次のようになります。
リスト : マクロ版 bag-of
(define-macro bag-of
(lambda (func)
`(let ((prev-fail *amb-fail*)
(result '()))
(if (call/cc
(lambda (cont)
(set! *amb-fail* (lambda () (cont false)))
(let ((v ,func))
(set! result (cons v result))
(cont true))))
(*amb-fail*))
(set! *amb-fail* prev-fail)
(reverse result))))
関数 bag-of をマクロ定義しただけなので、とくに難しいところはないと思います。簡単な実行例を示します。
Scm> (initialize-amb-fail) <closure> Scm> (bag-of (list (amb 1 2) (amb 3 4))) ((1 3) (1 4) (2 3) (2 4)) Scm> (bag-of (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))
最後に地図の配色問題を解いてみましょう。今回は、下図に示す簡単な地図を 4 色で塗り分けてみます。
┌─────────┐
│ ａ │
├──┬───┬──┤
│ ｂ │ ｃ │ ｄ │
├──┴─┬─┴──┤
│ ｅ │ ｆ │
└────┴────┘
図：簡単な地図
なお、地図は下記文献 (276頁) より引用しました。
プログラムは次のようになります。
リスト : 地図の配色問題
(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
(lambda (p ls) (cdr (assoc p ls))))
(define same-color?
(lambda (region ls)
(let ((color (get-color region ls)))
(find (lambda (x) (eq? (get-color x ls) color))
(cdr (assoc region adjacent))))))
(define color-map
(lambda ()
(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? でチェックします。同じ色が使われていたら、バックトラックして異なる色を選び直します。最後に連想リストを返します。
実行結果を示します。
Scm> (initialize-amb-fail) <closure> Scm> (color-map) ((a . blue) (b . green) (c . red) (d . green) (e . blue) (f . yellow))
┌─────────┐
│ ■ │
├──┬───┬──┤
│ ■ │ ■ │ ■ │
├──┴─┬─┴──┤
│ ■ │ ■ │
└────┴────┘
図 : 解答
このように amb を使うと問題を簡単に解くことができますが、生成されるデータ数が多くなると実行時間が極端に遅くなります。ようするに「生成検定法」と同じなので、なるべく無駄なデータを生成しないように工夫する必要があります。ご注意くださいませ。
;;;
;;; amb0.scm : 非決定性 amb (関数版)
;;;
;;; Copyright (C) 2013-2021 Makoto Hiroi
;;;
;;; バックトラックするときの継続を格納する
(define *amb-fail* false)
;;; 初期化
(define initialize-amb-fail
(lambda ()
(set! *amb-fail*
(lambda () (error "amb tree exhausted")))))
;;; 非決定性 amb (関数版)
(define amb
(lambda 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 false)))
(cont-s x))))
args)
(prev-fail)))))))
;;; 条件 pred を満たさない場合はバックトラックする
(define assert
(lambda (pred)
(if (not pred) (amb))))
;;; ls から n 個を取り出す順列
(define perm
(lambda (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)))))))
(define bag-of
(lambda (func)
(let ((prev-fail *amb-fail*)
(result '()))
(if (call/cc
(lambda (cont)
(set! *amb-fail* (lambda () (cont false)))
(set! result (cons (func) result))
(cont true)))
(*amb-fail*))
(set! *amb-fail* prev-fail)
(reverse result))))
;;;
;;; 論理パズル
;;;
;;; データの生成
(define make-data
(lambda (name)
(list name
(amb 1 2 3)
(amb 'US 'IL 'AU)
(amb 'basket 'cricket 'tennis))))
;;; アクセス関数
(define get-rank (lambda (x) (second x)))
(define get-nation (lambda (x) (third x)))
(define get-sports (lambda (x) (fourth x)))
;;; 国籍が x の人を探す
(define find-nation
(lambda (x . ls)
(find (lambda (a) (eq? x (get-nation a))) ls)))
;;; スポーツ x が好きな人を探す
(define find-sports
(lambda (x . ls)
(find (lambda (a) (eq? x (get-sports a))) ls)))
;;; 重複した要素が有るか
(define duplicate?
(lambda (pred ls)
(cond ((null? ls) false)
((find (lambda (x) (pred (car ls) x)) (cdr ls)) true)
(else (duplicate? pred (cdr ls))))))
;;; 要素が異なっているか
(define check?
(lambda ls
(duplicate? (lambda (x y) (any eqv? (cdr x) (cdr y))) ls)))
;;; 解法
(define puzzle
(lambda ()
(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))))
;;;
;;; amb1.scm : 非決定性計算 (マクロ版)
;;;
;;; Copyright (C) 2013-2021 Makoto Hiroi
;;;
;;; バックトラックするときの継続を格納する
(define *amb-fail* false)
;;; 初期化
(define initialize-amb-fail
(lambda ()
(set! *amb-fail*
(lambda () (error "amb tree exhausted")))))
;;; 非決定性 amb (マクロ版)
(define-macro amb
(lambda args
`(let ((prev-fail *amb-fail*))
(call/cc
(lambda (cont-s)
,@(map (lambda (x)
`(call/cc
(lambda (cont-f)
(set! *amb-fail*
(lambda ()
(set! *amb-fail* prev-fail)
(cont-f false)))
(cont-s ,x))))
args)
(prev-fail))))))
;;; マクロ版
(define-macro bag-of
(lambda (func)
`(let ((prev-fail *amb-fail*)
(result '()))
(if (call/cc
(lambda (cont)
(set! *amb-fail* (lambda () (cont false)))
(let ((v ,func))
(set! result (cons v result))
(cont true))))
(*amb-fail*))
(set! *amb-fail* prev-fail)
(reverse result))))
;;; 条件 pred を満たさない場合はバックトラックする
(define assert
(lambda (pred)
(if (not pred) (amb))))
;;;
;;; 地図の配色問題
;;;
(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
(lambda (p ls) (cdr (assoc p ls))))
(define same-color?
(lambda (region ls)
(let ((color (get-color region ls)))
(find (lambda (x) (eq? (get-color x ls) color))
(cdr (assoc region adjacent))))))
(define color-map
(lambda ()
(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)))