関数型電卓プログラムの作成 (7)
今回は継続を使った簡単なサンプルプログラムを作ってみましょう。
●大域脱出
継続を使って「大域脱出」することができます。次の例を見てください。
Calc> def bar1(k) print(1), putc(10) end bar1 Calc> def bar2(k) print(2), putc(10), k(0) end bar2 Calc> def bar3(k) print(3), putc(10) end bar3 Calc> def test(k) bar1(k), bar2(k), bar3(k) end test Calc> callcc(fn(k) test(k) end); 1 2 0
これを図に表すと次のようになります。
bar2 からトップレベルへ脱出するので、bar3 は呼び出されていません。正常に動作していますね。
●繰り返しの中断
繰り返しの中断も簡単です。次のように callcc で脱出することができます。
Calc> callcc(fn(k)
let i = 0 in
while i < 10 do
if i > 5 then k(-1) end,
print(i),
putc(10),
i = i + 1
end
end
end);
0
1
2
3
4
5
~1
このように、k に格納された継続を評価すれば、繰り返しを途中で中断することができます。また、二重ループからの脱出も簡単です。簡単な例を示します。
Calc> callcc(fn(k)
let i = 0 in
while i < 5 do
let j = 0 in
while j < 5 do
print(i),
print(j),
putc(10),
if i + j > 5 then k(-1) end,
j = j + 1
end
end,
i = i + 1
end
end
end);
00
01
02
03
04
10
11
12
13
14
20
21
22
23
24
~1
高階関数の処理を途中で中断することも簡単にできます。たとえば、連結リストの要素をチェックし、不適当な要素を見つけた場合は nil を返すマップ関数 mapCheck を作ってみましょう。プログラムは次のようになります。
Calc> def mapCheck(pred, f, ls)
callcc(fn(k)
map(fn(x) if pred(x) then
k(nil)
else
f(x)
end end,
ls)
end)
end
mapCheck
Calc> a = iota(1, 10);
(1 2 3 4 5 6 7 8 9 10)
Calc> mapCheck(fn(x) x > 10 end, fn(x) x * x end, a);
(1 4 9 16 25 36 49 64 81 100)
Calc> mapCheck(fn(x) x > 5 end, fn(x) x * x end, a);
要素をチェックする述語は引数 pred に渡します。pred が真を返す場合は継続 k を評価して nil を返します。
●再帰呼び出しからの脱出
再帰呼び出しから脱出することも簡単です。
リスト : flatten の再帰呼び出しから脱出する場合
def flatten1(ls)
callcc(fn(k)
let rec
flat = fn(ls)
if null(ls) then
nil
else
if pair(ls) then
if null(car(ls)) then
k(nil)
else
append(flat(car(ls)), flat(cdr(ls)))
end
else
cons(ls, nil)
end
end
end
in
flat(ls)
end
end)
end
リストを平坦化する関数 flatten で、要素に nil が含まれている場合は nil を返します。
簡単な実行例を示します。
Calc> a = list(1, list(2, list(3, list(4, list(5), 6), 7), 8), 9); (1 (2 (3 (4 (5) 6) 7) 8) 9) Calc> flatten1(a); (1 2 3 4 5 6 7 8 9) Calc> b = list(1, list(2, list(3, list(4, list(5), nil, 6), 7), 8), 9); (1 (2 (3 (4 (5) () 6) 7) 8) 9) Calc> flatten1(b);
次は、連結リストを「木」とみなして、木からデータを探索する関数 memberTree を作ってみましょう。プログラムは次のようになります。
リスト : 木の探索
def memberTree(x, xs)
callcc(fn(k)
let rec
iter = fn(xs)
if pair(xs) then
iter(car(xs)),
iter(cdr(xs))
else
if not(null(xs)) and x == xs then
k(1)
end
end
end
in
iter(xs)
end
end)
end
探索は局所関数 iter で行います。callcc で取り出した継続 k は、探索の途中で値を返すために使用します。リストを二分木と考えると、リストの先頭要素が左部分木、残りのリストが右部分木に相当します。左右の部分木に対して iter を再帰呼び出しすればいいわけです。今回は葉を探索するので、x と等しい要素が見つけたならば、継続 k を呼び出して 1 を返します。そうでなければ (else 節がないので) 0 を返して探索を続行します。
簡単な実行例を示します。
Calc> a; (1 (2 (3 (4 (5) 6) 7) 8) 9) Calc> memberTree(5, a); 1 Calc> memberTree(10, a); 0 Calc> memberTree(1, a); 1 Calc> memberTree(9, a); 1
●ジェネレータの生成
次はジェネレータを生成する関数 makeGen を試してみます。
リスト : ジェネレータを生成する関数
def makeGen(proc, ls)
let rec
resume = fn(ret)
proc(fn(x) ret = callcc(fn(cont) resume = cont, ret(x) end) end, ls),
ret(nil)
end
in
fn() callcc(fn(cont) resume(cont) end) end
end
end
プログラムの内容は拙作のページ Scheme 入門 継続と継続渡しスタイル で作成した関数 make-iter と同じです。それでは実行してみましょう。
Calc> a = iota(1, 8); (1 2 3 4 5 6 7 8) Calc> g = makeGen(foreach, a); <Function> Calc> g(); 1 Calc> g(); 2 Calc> g(); 3 Calc> g(); 4 Calc> g(); 5 Calc> g(); 6 Calc> g(); 7 Calc> g(); 8 Calc> g();
正常に動作していますね。次に示すように、makeGen は順列を生成する関数 perm に適用することも可能です。
リスト : 順列の生成
def perm(f, ls)
let rec
iter = fn(ls, a)
if null(ls) then
f(a)
else
foreach(fn(x) iter(remove(x, ls), cons(x, a)) end, ls)
end
end
in
iter(ls, nil)
end
end
簡単な実行例を示します。
Calc> perm(print, iota(1, 3)); (3 2 1)(2 3 1)(3 1 2)(1 3 2)(2 1 3)(1 2 3)0 Calc> p = makeGen(perm, iota(1, 3)); <Function> Calc> p(); (3 2 1) Calc> p(); (2 3 1) Calc> p(); (3 1 2) Calc> p(); (1 3 2) Calc> p(); (2 1 3) Calc> p(); (1 2 3) Calc> p();
●コルーチンの作成
次は継続を使ってコルーチンを作りましょう。コルーチンについては、拙作のページ コルーチン をお読みください。
プログラムは次のようになります。
リスト : コルーチン
# 脱出先の継続
coRet = nil;
coErr = nil;
# 初期化
def coInitialize()
callcc(fn(k) coErr = k, coRet = nil end)
end
# コルーチンの生成
def coCreate(proc)
cons(nil, fn(z) coRet(cons(nil, proc(nil))) end)
end
# 実行の中断
def coYield(x)
callcc(fn(k) coRet(cons(k, x)) end)
end
# 実行の再開
def coResume(co)
let
save = car(co), proc = cdr(co)
in
if null(proc) or not null(save) then
# dead coroutine or double resume
coErr(nil)
else
let
v = callcc(fn(k) setCar(co, coRet),
coRet = k,
proc(nil) end)
in
coRet = car(co),
setCar(co, nil),
setCdr(co, car(v)),
cdr(v)
end
end
end
end
基本的な考え方は拙作のページ コルーチン で作成したプログラムと同じです。大域変数 coRet に親コルーチンに戻るための継続を、coErr にはエラーが発生したときトップレベルに戻るための継続をセットします。関数 coInitialize は coErr を取り出した継続 k で、coRet を nil で初期化します。コルーチンを使うときは、最初に coInitialize を呼び出してください。
関数 coCreate はコルーチンを表すデータ (リスト) を生成して返します。CAR 部に coRet の値を保存し、CDR 部に実行を再開するための継続を保存します。最初、CAR 部は nil に、CDR 部は fn() coRet(cons(nil, proc(nil))) end に初期化します。この匿名関数を実行すると、引数 proc に渡した関数が評価されてコルーチンがスタートします。そして、最後に proc の返り値を格納したリストが継続 coRet に渡されて処理を終了します。
コルーチンで実行を中断するには関数 coYield を使います。coYield は実行を再開するための継続 k を取り出して、coRet で k と引数 x を返します。
実行の再開は関数 coResume で行います。引数 co からデータを取り出して局所変数 save と proc にセットします。proc が nil の場合、コルーチンの実行は終了しているので coErr でトップレベルに戻ります。また、save が nil でない場合、そのコルーチンは実行中なので coErr でトップレベルに戻ります。
実行を再開する場合、最初に callcc で継続 k を取り出します。coRet の値を co の CAR 部に保存してから、coRet の値を継続 k に書き換えます。そして、co の CDR 部に格納されている継続 proc を実行します。継続は引数をひとつとるので、ここでは nil を渡しています。
coYield を実行すると、その値が callcc の返り値となり、変数 v にセットされます。coRet を元の値に戻して、co の CAR 部 を nil に書き換えます。そして、co の CDR 部に実行を再開するための継続 car(v) をセットします。最後に値 cdr(v) を返します。
簡単な実行例を示します。
Calc> coInitialize(); Calc> c = coCreate(fn(x) coYield(1), coYield(2), coYield(3), 0 end); (() . <Function>) Calc> coResume(c); 1 Calc> coResume(c); 2 Calc> coResume(c); 3 Calc> coResume(c); 0 Calc> coResume(c);
一番最後はコルーチンが終了しているため、トップレベルに戻っています。
●ジェネレータの生成 (2)
コルーチンを使うと、ジェネレータを簡単に作成することができます。次のリストを見てください。
リスト ; ジェネレータ (2) def makeGen2(f, xs) coCreate(fn(z) f(fn(x) coYield(x) end, xs) end) end
f は高階関数で、f に渡す関数で coYield を呼び出して匿名関数の引数 x を返しています。これで xs の要素をひとつずつ取り出して返すことができます。
簡単な例を示しましょう。
Calc> c = makeGen2(foreach, list(1, 2, 3, 4, 5)); (() . <Function>) Calc> coResume(c); 1 Calc> coResume(c); 2 Calc> coResume(c); 3 Calc> coResume(c); 4 Calc> coResume(c); 5 Calc> coResume(c); 0
0 は foreach の返り値です。
●順列の生成
順列を生成するジェネレータは makeGen を使わなくても、コルーチンで直接プログラムすることができます。
リスト : 順列の生成
def genPerm(n, m)
coCreate(fn()
if m == 0 then
coYield(nil)
else
let
x = nil,
g = genPerm(n, m - 1)
in
while pair(x = coResume(g)) or null(x) do
let y = 1 in
while y <= n do
if not member(y, x) then
coYield(cons(y, x))
end,
y = y + 1
end
end
end
end
end,
0
end)
end
関数 genPerm は順列を生成するコルーチンを返します。m が 0 の場合、要素の選択が終わったので coYield で nil を返します。そうでなければ、genPerm を呼び出して新しいコルーチン g を生成します。そして、while でその要素 (順列を格納したリスト) を取り出して x にセットし、それに含まれていない数字 y を選びます。あとは coYield で y を追加したリストを返します。コルーチンの返り値は 0 なので、この値で while ループが終了します。
簡単な実行例を示します。
Calc> c = genPerm(3, 3); (() . <Function>) Calc> while a = coResume(c) do print(a), putc(10) end; (3 2 1) (2 3 1) (3 1 2) (1 3 2) (2 1 3) (1 2 3) 0
最後の 0 は while の返り値です。
●エラトステネスの篩
次はコルーチンを使って素数を求めるプログラムを作ってみましょう。考え方は簡単です。最初に、2 から始まる整数列を生成するコルーチンを用意します。この場合、コルーチンを「遅延ストリーム」として使います。2 は素数なので、この整数列から 2 で割り切れる整数を取り除き除きます。ここでもコルーチンを使って、入力ストリームから 2 で割り切れる整数を取り除いたコルーチンを返すフィルターを作ります。
2 で割り切れる整数が取り除かれたので、次の要素は 3 になります。今度は 3 で割り切れる整数を取り除けばいいのです。これもフィルターを使えば簡単です。このとき、入力用のコルーチンは 2 で割り切れる整数が取り除かれています。したがって、このコルーチンに対して 3 で割り切れる整数を取り除くようにフィルターを設定すればいいわけです。
このように、素数を見つけたらそれで割り切れる整数を取り除いていくアルゴリズムを「エラトステネスの篩」といいます。ようするに、2 から始まる整数を生成するコルーチンに対して、見つけた素数 2, 3, 5, 7, 11, ... を順番にフィルターで設定して素数でない整数をふるい落としていくわけです。
プログラムは次のようになります。
リスト : エラトステネスの篩
# n から始まる整数列
def integers(n)
coCreate(fn() while 1 do coYield(n), n = n + 1 end end)
end
# フィルター
def filter(pred, src)
coCreate(fn()
while 1 do
let m = coResume(src) in
if pred(m) then
coYield(m)
end
end
end
end)
end
def sieve(x)
let nums = integers(2) in
while x > 0 do
let n = coResume(nums) in
print(n),
putc(32),
nums = filter(fn(y) y % n != 0 end, nums)
end,
x = x - 1
end
end
end
関数 integers は n から始まる整数列を生成するコルーチンです。関数 filter は述語 pred が偽を返す要素をコルーチン src から取り除きます。src から要素を取り出して m にセットします。pred(m) の返り値が真であれば coYield(m) で親コルーチンに m を返します。これで述語が偽を返す要素を取り除くことができます。
素数を求める関数 sieve も簡単です。引数 x は求める素数の個数です。最初に、2 から始まる整数列を integers で生成して変数 nums に セットします。このコルーチン nums の先頭要素が素数になります。coResume(nums) でコルーチンから素数を取り出して n にセットします。次に n を表示して、n で割り切れる整数を取り除くフィルターを生成して nums にセットします。つまり、x 個の素数を求めるために、x 個のフィルターをストリームに重ねていくわけです。
それでは実際に sieve(100) を実行してみましょう。
Calc> sieve(100); 2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71 73 79 83 89 97 101 103 107 109 113 127 131 137 139 149 151 157 163 167 173 179 181 191 193 197 199 211 223 227 229 233 239 241 251 257 263 269 271 277 281 283 293 307 311 313 317 331 337 347 349 353 359 367 373 379 383 389 397 401 409 419 421 431 433 439 443 449 457 461 463 467 479 487 491 499 503 509 521 523 541 0
最後の 0 は sieve の返り値です。正常に動作していますね。
●非決定性
次は非決定性計算を行う関数 amb を作ってみましょう。非決定性計算については、拙作のページ 非決定性 をお読みください。
プログラムは次のようになります。
リスト : 非決定性
# 初期化
ambFail = nil;
def initialize()
callcc(fn(k) ambFail = cons(k, nil) end)
end
# バックトラック
def fail()
if null(ambFail) then
nil
else
let k = car(ambFail) in
ambFail = cdr(ambFail),
k(nil)
end
end
end
# リスト用
def ambL(xs, ret)
if null(xs) then
fail()
else
callcc(fn(k) ambFail = cons(k, ambFail), ret(car(xs)) end),
ambL(cdr(xs), ret)
end
end
# ベクタ用
def ambV(xs, ret)
let
s = len(xs), i = 0
in
while i < s do
callcc(fn(k) ambFail = cons(k, ambFail), ret(xs[i]) end),
i = i + 1
end,
fail()
end
end
# 要素をひとつずつ選ぶ
def amb(xs)
callcc(fn(k)
if pair(xs) then
ambL(xs, k)
else
ambV(xs, k)
end
end)
end
ambFail はバックトラックするときの継続を格納するリストです。これをスタックとして使用します。つまり、継続を ambFail にプッシュしておいて、バットラックするときは ambFail から継続をポップして実行します。これで深さ優先探索と同様にバックトラックすることができます。
関数 initialize は ambFail を initialize で取り出した継続 k で初期化します。amb でセットされたバックトラックがなくなった場合、この継続が評価されてトップレベルの処理に戻ります。関数 fail は ambFail の先頭から継続 k を取り出して実行します。このとき、k の引数には nil を渡します。ambFail が空リストの場合は nil を返します。
関数 ambL はリスト xs の要素を順番に取り出していきます。関数 ambV はベクタ xs の要素を順番に取り出していきます。どちらの関数も引数 ret が脱出先継続になります。amb はバックトラックしないといけないので、ジェネレータやコルーチンのように脱出先継続を書き換えてはいけません。最初に amb を呼び出したときに取り出した継続を使って値を返します。
実際の処理は、バックトラックするときの継続を callcc で取り出して ambFail にプッシュします。そして、脱出先継続 ret を使って要素 x を返します。fail でバックトラックすると callcc の次の処理に戻るので、要素をひとつずつ取り出すことができます。要素がなくなったら、fail を呼び出すことに注意してください。これで、以前に実行した amb にバックトラックすることができます。
それでは実際に試してみましょう。
Calc> initialize(); (<Function>) Calc> amb(list(1,2,3)); 1 Calc> fail(); 2 Calc> fail(); 3 Calc> fail(); Calc> initialize(); (<Function>) Calc> amb([1,2,3]); 1 Calc> fail(); 2 Calc> fail(); 3 Calc> fail(); Calc> initialize(); (<Function>) Calc> list(amb(list(1,2,3)), amb(list(4,5))); (1 4) Calc> fail(); (1 5) Calc> fail(); (2 4) Calc> fail(); (2 5) Calc> fail(); (3 4) Calc> fail(); (3 5) Calc> fail(); Calc> initialize(); (<Function>) Calc> [amb([1,2,3]), amb([4,5])]; [1, 4] Calc> fail(); [1, 5] Calc> fail(); [2, 4] Calc> fail(); [2, 5] Calc> fail(); [3, 4] Calc> fail(); [3, 5] Calc> fail();
●順列の生成 (2)
簡単な例として、順列を生成するプログラムを作ってみましょう。次のリストを見てください。
リスト : 順列の生成
def assert(pred)
if pred then fail() end
end
# 順列の生成
def perm1(n, xs)
let rec
iter = fn(n, a)
if n == 0 then
a
else
let x = amb(xs) in
assert(member(x, a)),
iter(n - 1, cons(x, a))
end
end
end
in
iter(n, nil)
end
end
関数 assert は pred が偽の場合は fail を実行してバックトラックします。amb を使うと順列を生成する関数 perm1 は簡単に実現できます。amb で 1 から n までの要素を 1 つ選び、それが順列 a に含まれていないことを assert で確認します。同じ要素が含まれていれば、バックトラックして異なる要素を選びます。n 個の要素を選んだらリスト a を逆順にして返します。
それでは実行してみましょう。
Calc> initialize(); (<Function>) Calc> perm1(3, list(1,2,3)); (3 2 1) Calc> fail(); (2 3 1) Calc> fail(); (3 1 2) Calc> fail(); (1 3 2) Calc> fail(); (2 1 3) Calc> fail(); (1 2 3) Calc> fail(); Calc> initialize(); (<Function>) Calc> perm1(4, list(1,2,3,4)); (4 3 2 1) Calc> fail(); (3 4 2 1) Calc> fail(); (4 2 3 1) Calc> fail(); (2 4 3 1) Calc> fail(); (3 2 4 1) Calc> fail(); (2 3 4 1) Calc> fail(); (4 3 1 2) Calc> fail(); (3 4 1 2) Calc> fail(); (4 1 3 2) Calc> fail(); (1 4 3 2) Calc> fail(); (3 1 4 2) Calc> fail(); (1 3 4 2) Calc> fail(); (4 2 1 3) Calc> fail(); (2 4 1 3) Calc> fail(); (4 1 2 3) Calc> fail(); (1 4 2 3) Calc> fail(); (2 1 4 3) Calc> fail(); (1 2 4 3) Calc> fail(); (3 2 1 4) Calc> fail(); (2 3 1 4) Calc> fail(); (3 1 2 4) Calc> fail(); (1 3 2 4) Calc> fail(); (2 1 3 4) Calc> fail(); (1 2 3 4) Calc> fail();
このように、バックトラックするたびに順列を一つずつ生成することができます。
●解をすべて求める
非決定性のプログラムはバックトラックすることで全ての解を求めることができます。このとき、見つけた解をリストに格納して返す関数があると便利です。次のリストを見てください。
リスト : 見つけた解をリストに格納して返す
def bagOf(f)
let
result = nil
in
if callcc(fn(k) ambFail = cons(k, ambFail),
result = cons(f(), result),
k(1) end)
then
fail()
else
reverse(result)
end
end
end
関数 bagOf は与えられた関数 f を実行して、その結果をリスト result に格納して返します。関数 f の中で非決定性計算を行う関数を呼び出します。最初に callcc で継続 k を取り出して、ambFail にプッシュします。次に、関数 f を実行してその返り値を result に追加します。
k(1) を実行すると、callcc の返り値が 1 となり、if の then 節にある fail が実行されます。ここで関数 f の処理にバックトラックして、解が見つかればその値を返します。つまり、解が存在する限り次の処理が繰り返されます。
result = cons(f(), result) -> k(1) -> fail() -> result = cons(f(), result) -> ...
これで複数の解を result に格納することができます。関数 f で解が見つからない場合、最初に ambFail にセットした継続 k が実行されます。この継続には nil が渡されるので、if 条件が偽と判定され、バックトラックを終了します。reverse で result を反転してから返します。
簡単な実行例を示しましょう。
Calc> initialize(); (<Function>) Calc> bagOf(fn() amb(list(1,2,3,4,5)) end); (1 2 3 4 5) Calc> bagOf(fn() amb([1,2,3,4,5]) end); (1 2 3 4 5) Calc> bagOf(fn() list(amb(list(1,2,3)),amb(list(4,5))) end); ((1 4) (1 5) (2 4) (2 5) (3 4) (3 5)) Calc> bagOf(fn() [amb([1,2,3]),amb([4,5])] end); ([1, 4] [1, 5] [2, 4] [2, 5] [3, 4] [3, 5]) Calc> bagOf(fn() perm1(3, list(1,2,3)) end); ((3 2 1) (2 3 1) (3 1 2) (1 3 2) (2 1 3) (1 2 3))
このように bagOf を使って全ての解を求めることができます。
●経路の探索
もうひとつ簡単な例題として、拙作のページ 経路の探索 で取り上げた問題を解いてみましょう。経路図を再掲します。
図 : 経路図
プログラムは次のようになります。
リスト : 経路の探索
# 隣接リスト
# A = 0, B = 1, C = 2, D = 3,
# E = 4, F = 5, G = 6
adjacent = [[1, 2],
[0, 2, 3],
[0, 1, 4],
[1, 4, 5],
[2, 3, 6],
[3],
[6]];
# 深さ優先探索
def dfs(start, goal)
let rec
iter = fn(path)
if car(path) == goal then
reverse(path)
else
let
x = amb(adjacent[car(path)])
in
assert(member(x, path)),
iter(cons(x, path))
end
end
end
in
iter(list(start))
end
end
goal に到達していない場合、amb で隣接リストから要素を一つ選びます。そして、選んだ要素 x が path に含まれていないことを assert で確認します。最後に、path の先頭に x を追加して探索を続行します。
実行結果は次のようになります。
Calc> bagOf(fn() dfs(0, 6) end); ((0 1 2 4 6) (0 1 3 4 6) (0 2 1 3 4 6) (0 2 4 6))
amb は深さ優先探索なので、最初に見つかる経路が最短経路とは限りません。最短経路を求めるには「幅優先探索」のほうが適しています。amb を幅優先探索で実現することも可能です。興味のある方は拙作のページ 非決定性 をお読みください。
●プログラムリスト
#
# cont_test.cal : 継続のテスト
#
# Copyright (C) 2012-2021 Makoto Hiroi
#
# リスト操作関数
def null(xs) isNil(xs) end
def pair(xs) isPair(xs) end
def reverse(xs)
let rec
iter = fn(xs, a)
if null(xs) then a else iter(cdr(xs), cons(car(xs), a)) end
end
in
iter(xs, nil)
end
end
def member(x, xs)
if null(xs) then
nil
else
if car(xs) == x then
xs
else
member(x, cdr(xs))
end
end
end
def foreach(f, xs)
if pair(xs) then
f(car(xs)),
foreach(f, cdr(xs))
end
end
# リストの平坦化
def flatten1(ls)
callcc(fn(k)
let rec
flat = fn(ls)
if null(ls) then
nil
else
if pair(ls) then
if null(car(ls)) then
k(nil)
else
append(flat(car(ls)), flat(cdr(ls)))
end
else
cons(ls, nil)
end
end
end
in
flat(ls)
end
end)
end
# 木の探索
def memberTree(x, xs)
callcc(fn(k)
let rec
iter = fn(xs)
if pair(xs) then
iter(car(xs)),
iter(cdr(xs))
else
if not(null(xs)) and x == xs then
k(1)
end
end
end
in
iter(xs)
end
end)
end
# 順列の生成
def perm(f, ls)
let rec
iter = fn(ls, a)
if null(ls) then
f(a)
else
foreach(fn(x) iter(remove(x, ls), cons(x, a)) end, ls)
end
end
in
iter(ls, nil)
end
end
# ジェネレータの生成
def makeGen(proc, ls)
let rec
resume = fn(ret)
proc(fn(x) ret = callcc(fn(cont) resume = cont, ret(x) end) end, ls),
ret(nil)
end
in
fn() callcc(fn(cont) resume(cont) end) end
end
end
#
# コルーチン
#
# 脱出先の継続
coRet = nil;
coErr = nil;
# 初期化
def coInitialize()
callcc(fn(k) coErr = k, coRet = nil end)
end
# コルーチンの生成
def coCreate(proc)
cons(nil, fn() coRet(cons(nil, proc(nil))) end)
end
# 実行の中断
def coYield(x)
callcc(fn(k) coRet(cons(k, x)) end)
end
# 実行の再開
def coResume(co)
let
save = car(co), proc = cdr(co)
in
if null(proc) then
# dead coroutine
coErr(nil)
else
if not null(save) then
# double resume
coErr(nil)
else
let
v = callcc(fn(k) setCar(co, coRet),
coRet = k,
proc(nil) end)
in
coRet = car(co),
setCar(co, nil),
setCdr(co, car(v)),
cdr(v)
end
end
end
end
end
# ジェネレータ
def makeGen2(f, xs)
coCreate(fn() f(fn(x) coYield(x) end, xs) end)
end
# 順列の生成
def genPerm(n, m)
coCreate(fn()
if m == 0 then
coYield(nil)
else
let
x = nil,
g = genPerm(n, m - 1)
in
while pair(x = coResume(g)) or null(x) do
let y = 1 in
while y <= n do
if not member(y, x) then
coYield(cons(y, x))
end,
y = y + 1
end
end
end
end
end,
0
end)
end
# n から始まる整数列
def integers(n)
coCreate(fn() while 1 do coYield(n), n = n + 1 end end)
end
# フィルター
def filter(pred, src)
coCreate(fn()
while 1 do
let m = coResume(src) in
if pred(m) then
coYield(m)
end
end
end
end)
end
# エラトステネスの篩
def sieve(x)
let nums = integers(2) in
while x > 0 do
let n = coResume(nums) in
print(n),
putc(32),
nums = filter(fn(y) y % n != 0 end, nums)
end,
x = x - 1
end
end
end
#
# 非決定性
#
# 初期化
ambFail = nil;
def initialize()
callcc(fn(k) ambFail = cons(k, nil) end)
end
# バックトラック
def fail()
if null(ambFail) then
nil
else
let k = car(ambFail) in
ambFail = cdr(ambFail),
k(nil)
end
end
end
# リスト用
def ambL(xs, ret)
if null(xs) then
fail()
else
callcc(fn(k) ambFail = cons(k, ambFail), ret(car(xs)) end),
ambL(cdr(xs), ret)
end
end
# ベクタ用
def ambV(xs, ret)
let
s = len(xs), i = 0
in
while i < s do
callcc(fn(k) ambFail = cons(k, ambFail), ret(xs[i]) end),
i = i + 1
end,
fail()
end
end
# 非決定性
def amb(xs)
callcc(fn(k)
if pair(xs) then
ambL(xs, k)
else
ambV(xs, k)
end
end)
end
# pred が真のときバックトラックする
def assert(pred)
if pred then fail() end
end
# すべての解を求める
def bagOf(f)
let
result = nil
in
if callcc(fn(k) ambFail = cons(k, ambFail),
result = cons(f(), result),
k(1) end)
then
fail()
else
reverse(result)
end
end
end
# 順列の生成
def perm1(n, xs)
let rec
iter = fn(n, a)
if n == 0 then
a
else
let x = amb(xs) in
assert(member(x, a)),
iter(n - 1, cons(x, a))
end
end
end
in
iter(n, nil)
end
end
# 経路の探索
# 1---3---5
# /| |
# 0 | |
# \| |
# 2---4---6
# 隣接リスト
adjacent = [[1, 2],
[0, 2, 3],
[0, 1, 4],
[1, 4, 5],
[2, 3, 6],
[3],
[6]];
# 深さ優先探索
def dfs(start, goal)
let rec
iter = fn(path)
if car(path) == goal then
reverse(path)
else
let
x = amb(adjacent[car(path)])
in
assert(member(x, path)),
iter(cons(x, path))
end
end
end
in
iter(list(start))
end
end
改訂 2021 年 6 月 5 日