次は、要素を昇順に出力する 2 つの遅延ストリームを併合 (マージ: merge) する関数を作りましょう。次のリストを見てください。
リスト : 遅延ストリームのマージ
;; 遅延ストリームの併合
(defun stream-merge (s1 s2)
(cond ((null s1) s2)
((null s2) s1)
(t
(if (<= (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1) (stream-merge (stream-cdr s1) s2))
(stream-cons (stream-car s2) (stream-merge s1 (stream-cdr s2)))))))
stream-merge は 2 つの遅延ストリームを併合して新しい遅延ストリームを返します。s1 が空であれば s2 を返し、s2 が空ならば s1 を返します。そうでなければ、遅延ストリームの先頭要素を比較します。s1 の要素が s2 の要素以下ならば s1 の要素を、そうでなければ s2 の要素を遅延ストリームに格納します。
簡単な実行例を示しましょう。
* (setq *s1* (iterate #'(lambda (x) (+ x 2)) 1)) (1 . #<CLOSURE ...>) * (setq *s2* (iterate #'(lambda (x) (+ x 2)) 2)) (2 . #<CLOSURE ...>) * (setq *s3* (stream-merge *s1* *s2*)) (1 . #<CLOSURE ...>) * (stream-take *s3* 20) (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20) * (stream-take (stream-merge *s1* *s1*) 20) (1 1 3 3 5 5 7 7 9 9 11 11 13 13 15 15 17 17 19 19)
ここで、遅延ストリームには重複要素が存在せず、要素は昇順に出力されることを前提にすると、遅延ストリームでも集合演算を行うことができます。次のリストを見てください。
リスト : 集合演算
;; 和集合
(defun stream-union (s1 s2)
(cond ((null s1) s2)
((null s2) s1)
(t
(cond ((= (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1)
(stream-union (stream-cdr s1) (stream-cdr s2))))
((< (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1)
(stream-union (stream-cdr s1) s2)))
(t
(stream-cons (stream-car s2)
(stream-union s1 (stream-cdr s2))))))))
;; 積集合
(defun stream-intersect (s1 s2)
(cond ((or (null s1) (null s2)) nil)
((= (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1)
(stream-intersect (stream-cdr s1) (stream-cdr s2))))
((< (stream-car s1) (stream-car s2))
(stream-intersect (stream-cdr s1) s2))
(t
(stream-intersect s1 (stream-cdr s2)))))
stream-union は s1 と s2 から要素を取り出して、小さいほうを遅延ストリームに追加します。等しい場合は要素をひとつだけ追加します。このとき、s1 と s2 の両方から先頭要素を取り除くことに注意してください。
stream-intersect も簡単です。s1, s2 の先頭要素を比較して、等しい場合はその要素を遅延ストリームに追加します。s1 の要素が s2 の要素よりも小さい場合は、s1 を一つ進めて次の要素を調べます。s2 の要素が小さい場合は s2 の次の要素を調べます。
簡単な実行例を示しましょう。
* (setq *s1* (stream-map #'(lambda (x) (/ (* x (1+ x)) 2)) (iterate #'1+ 1))) (1 . #<CLOSURE ...>) * (setq *s2* (stream-map #'(lambda (x) (* x x)) (iterate #'1+ 1))) (1 . #<CLOSURE ...>) * (stream-take *s1* 20) (1 3 6 10 15 21 28 36 45 55 66 78 91 105 120 136 153 171 190 210) * (stream-take *s2* 20) (1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400) * (stream-take (stream-intersect *s1* *s2*) 7) (1 36 1225 41616 1413721 48024900 1631432881)
遅延ストリーム *s1* は「三角数」、*s2* は「四角数」を表します。これらの遅延ストリームを stream-union でまとめると、三角数または四角数の数列になります。stream-intersect でまとめると、三角数かつ四角数の数列 (平方三角数) になります。平方三角数は拙作のページ Puzzle DE Progamming 多角数 でも取り上げています。興味のある方はお読みくださいませ。
ここで stream-unio を使うと簡単に解ける問題を紹介しましょう。
7 以上の素数で割り切れない正の整数は、素因子が 2, 3, 5 しかない自然数のことで、これを「ハミング数 (Hamming Numbers)」といいます。ハミング数は素因数分解したとき、2i * 3j * 5k (i, j, k >= 0) の形式になります。たとえば、100 以下のハミング数は次のようになります。
1, 2, 3, 4, 5, 6, 8, 9, 10, 12, 15, 16, 18, 20, 24, 25, 27, 30, 32, 36, 40, 45, 48, 50, 54, 60, 64, 72, 75, 80, 81, 90, 96, 100
遅延ストリームを使うと「ハミングの問題」は簡単に解くことができます。小さい順にハミング数を出力する遅延ストリームを hs としましょう。hs は 1 から始まるので次のように定義できます。
(defvar hs (stream-cons 1 (...))
最初の要素は 1 なので、それに 2, 3, 5 を掛け算した値 (2, 3, 5) もハミング数になります。この値は次の S 式で生成することができます。
(stream-map #'(lambda (x) (* x 2) hs) (stream-map #'(lambda (x) (* x 3) hs) (stream-map #'(lambda (x) (* x 5) hs)
あとは、これらの遅延ストリームを stream-union でひとつにまとめて、小さい順に出力すればいいわけです。
プログラムと実行結果を示します。
リスト : ハミングの問題
(setq *hs*
(stream-cons
1
(stream-union
(stream-map #'(lambda (x) (* x 2)) *hs*)
(stream-union (stream-map #'(lambda (x) (* x 3)) *hs*)
(stream-map #'(lambda (x) (* x 5)) *hs*)))))
* (stream-take *hs* 100) (1 2 3 4 5 6 8 9 10 12 15 16 18 20 24 25 27 30 32 36 40 45 48 50 54 60 64 72 75 80 81 90 96 100 108 120 125 128 135 144 150 160 162 180 192 200 216 225 240 243 250 256 270 288 300 320 324 360 375 384 400 405 432 450 480 486 500 512 540 576 600 625 640 648 675 720 729 750 768 800 810 864 900 960 972 1000 1024 1080 1125 1152 1200 1215 1250 1280 1296 1350 1440 1458 1500 1536)
次は遅延ストリームを使って順列を生成するプログラムを作ってみましょう。遅延ストリームを使う場合、再帰呼び出しの一番深いところで順列が完成するようにプログラムするとうまくいきません。要素が n 個の順列を生成する場合、n - 1 個の順列を生成するストリームを生成し、そこに要素を一つ加えて n 個の順列を生成すると考えます。
まずは簡単な例として、遅延ストリームではなく、リストを使ってプログラムを作ってみます。次のリストを見てください。
リスト : 順列の生成
;; マッピングした結果を平坦化する
(defun flatmap (fn ls)
(apply #'append (mapcar fn ls)))
;; 順列の生成
(defun perm (n ls)
(if (zerop n)
'(())
(flatmap (lambda (x)
(mapcar #'(lambda (y) (cons x y))
(perm (1- n) (remove-if #'(lambda (z) (eql x z)) ls))))
ls)))
関数 perm は引数のリスト ls から n 個を選ぶ順列を生成し、それをリストに格納して返します。n = 0 が再帰の停止条件で、空リストを格納したリストを返します。このリストに対して要素を追加します。この処理は mapcar を二重に使うと簡単に実現できます。次の例を見てください。
* (mapcar #'(lambda (x) (cons 5 x)) '((1) (2) (3) (4) (5))) ((5 1) (5 2) (5 3) (5 4) (5 5)) * (mapcar #'(lambda (y) (mapcar #'(lambda (x) (cons y x)) '((1) (2) (3) (4) (5)))) '(5 6)) (((5 1) (5 2) (5 3) (5 4) (5 5)) ((6 1) (6 2) (6 3) (6 4) (6 5)))
リストの各要素に 5 を追加したい場合、mapcar を使うと簡単ですね。次は、リスト (5 6) の各要素を追加したリストを求めることを考えます。mapcar を二重にして、(5 6) の要素を匿名関数の引数 y に渡します。次の mapcar で y をリストに追加します。すると、返り値のリストには 5 を追加したリストと 6 を追加したリストが格納されます。mapcar を二重にしているので、リストの階層が 1 段深くなるわけです。そこで、リストを一段階だけ平坦化する flatmap を使います。
関数 perm の説明に戻ります。ラムダ式の中で perm を再帰呼び出しをして、n - 1 個を選ぶ順列を生成します。そして、その返り値にリスト ls の要素 x を追加すれば、n 個の順列を生成することができます。
簡単な実行例を示しましょう。
* (perm 4 '(1 2 3 4)) ((1 2 3 4) (1 2 4 3) (1 3 2 4) (1 3 4 2) (1 4 2 3) (1 4 3 2) (2 1 3 4) (2 1 4 3) (2 3 1 4) (2 3 4 1) (2 4 1 3) (2 4 3 1) (3 1 2 4) (3 1 4 2) (3 2 1 4) (3 2 4 1) (3 4 1 2) (3 4 2 1) (4 1 2 3) (4 1 3 2) (4 2 1 3) (4 2 3 1) (4 3 1 2) (4 3 2 1))
それでは、遅延ストリームを使ったプログラムを作ります。
リスト : 遅延ストリームによる順列の生成
;; 順列の生成
(defun make-perm (n s)
(if (zerop n)
(stream-cons nil nil)
(stream-flatmap
#'(lambda (x)
(stream-map #'(lambda (y) (cons x y))
(make-perm (1- n)
(stream-filter #'(lambda (z) (not (eql x z))) s))))
s)))
関数 make-perm はストリーム s の中から要素を n 個選ぶ順列を生成します。n = 0 の場合は空リストを格納したストリームを返します。あとは、stream-flatmap のラムダ式の中で、make-perm を再帰呼び出しして n - 1 個を選ぶ順列を生成します。ストリーム s から要素 x を取り除くため、stream-filter を使っています。これで順列を生成するストリームを作ることができます。
それでは実際に試してみましょう。
* (defvar *ps* (make-perm 4 (range 1 4))) *PS* * (stream-take *ps* 24) ((1 2 3 4) (1 2 4 3) (1 3 2 4) (1 3 4 2) (1 4 2 3) (1 4 3 2) (2 1 3 4) (2 1 4 3) (2 3 1 4) (2 3 4 1) (2 4 1 3) (2 4 3 1) (3 1 2 4) (3 1 4 2) (3 2 1 4) (3 2 4 1) (3 4 1 2) (3 4 2 1) (4 1 2 3) (4 1 3 2) (4 2 1 3) (4 2 3 1) (4 3 1 2) (4 3 2 1))
24 通りの順列をすべて求めることができました。
同様に、遅延ストリームを使って 8 クイーンを解くことができます。
リスト : 8 クイーンの解法 (遅延ストリーム版)
;; 衝突のチェック
(defun attack (x xs)
(labels ((attack-sub (x n ys)
(cond ((null ys) t)
((or (= (+ (car ys) n) x)
(= (- (car ys) n) x))
nil)
(t (attack-sub x (1+ n) (cdr ys))))))
(attack-sub x 1 xs)))
;; N Queen の解を求める
(defun queen (s)
(if (null s)
(stream-cons nil nil)
(stream-filter
#'(lambda (ls)
(if (null ls)
t
(attack (car ls) (cdr ls))))
(stream-flatmap
#'(lambda (x)
(stream-map #'(lambda (y) (cons x y))
(queen (stream-filter #'(lambda (z) (not (eql x z))) s))))
s))))
関数 queen は make-perm とほぼ同じですが、追加したクイーンが他のクイーンと衝突している場合は stream-filter を使って取り除いています。衝突をチェックする関数 attack は拙作のページ N Queens Problem で作成したプログラムと同じです。
それでは実行してみましょう。
* (stream-take (queen (range 1 8)) 10) ((1 5 8 6 3 7 2 4) (1 6 8 3 7 4 2 5) (1 7 4 6 8 2 5 3) (1 7 5 8 2 4 6 3) (2 4 6 8 3 1 7 5) (2 5 7 1 3 8 6 4) (2 5 7 4 1 8 6 3) (2 6 1 7 4 8 3 5) (2 6 8 3 1 4 7 5) (2 7 3 6 8 5 1 4))
解の総数は全部で 92 通りあります。
次はリストを木とみなして、木を巡回して要素を一つずつ出力するする遅延ストリームを作ってみましょう。ここでは、コンスセルを節 (node) とし要素を葉 (leaf) と考えます。木を巡回するプログラムは簡単です。次のリストを見てください。
リスト : 木の巡回
(defun iter-tree (fn ls)
(cond ((null ls) nil)
((atom ls) (funcall fn ls))
(t (iter-tree fn (car ls))
(iter-tree fn (cdr ls)))))
関数 iter-tree は木 ls を巡回して、各要素に関数 fn を適用します。iter-tree は関数 fn の副作用が目的なので、返り値に意味はありません。ls が空リストならば何もせずに空リストを返します。ls がアトムならば葉なので関数 fn を適用します。あとは、ls を car と cdr で分解して、iter-tree を再帰呼び出しするだけです。
このプログラムを CPS に変換すると、次のようになります。
リスト : 木の巡回 (CPS)
(defun iter-tree-cps (fn ls cont)
(cond ((null ls) (funcall cont))
((atom ls)
(funcall fn ls)
(funcall cont))
(t (iter-tree-cps
fn
(car ls)
#'(lambda () (iter-tree-cps
fn
(cdr ls)
#'(lambda () (funcall cont))))))))
iter-tree-cps は副作用が目的なので、継続に値を渡す必要はありません。ls が空リストの場合は cont を呼び出します。ls が葉の場合は fn を適用してから cont を呼び出します。次に、iter-tree-cps を再帰呼び出しして CAR の部分木をたどり、その継続の中で CDR の部分木をたどります。そして、その継続の中で cont を呼び出します。これで生成された継続を呼び出して、木を巡回することができます。
それでは実際に試してみましょう。
* (iter-tree-cps #'print '(a (b (c (d . e) f) g)) #'(lambda () '())) A B C D E F G NIL
このように、木を巡回して各要素に関数 fn を適用することができます。
木の巡回を CPS に変換すると、遅延ストリームに対応するのも簡単です。次のリストを見てください。
リスト : 木の巡回 (遅延ストリーム版)
(defun stream-of-tree (ls cont)
(cond ((null ls) (funcall cont))
((atom ls)
(stream-cons ls (funcall cont)))
(t (stream-of-tree
(car ls)
#'(lambda () (stream-of-tree
(cdr ls)
#'(lambda () (funcall cont))))))))
stream-of-tree は木を巡回してその要素を順番に出力する遅延ストリームを生成します。stream-of-tree は ls が葉の場合に stream-cons で遅延ストリームを生成して返します。このとき、ls が遅延ストリームの要素になり、遅延オブジェクトには継続 cont の呼び出しを格納します。この遅延オブジェクトを force することで、次の要素を求めることができます。
なお、stream-of-tree を呼び出すときに渡す継続が一番最後に呼び出されるので、遅延ストリームの終端 nil を返すように定義してください。
簡単な実行例を示しましょう。
* (defvar *tree* (stream-of-tree '(a (b (c (d . e) f) g)) #'(lambda () '()))) *TREE* * (stream-take *tree* 7) (A B C D E F G)
stream-of-tree を使うと、2 つの木を比較する関数 same-fringe-p を簡単に作ることができます。同じ葉を同じ並びで持つ場合、same-fringe-p は t を返します。次の例を見てください。
(same-fringe-p '(1 2 (3) 4) '(1 2 (3 4)) => #t (same-fringe-p '(1 2 (3) 4) '(1 2 (4) 3) => #f
最初の例の場合、木の構造は違いますが、要素はどちらの木も 1, 2, 3, 4 の順番で並んでいるので、same-fringe-p は #t を返します。次の例では、木の構造は同じですが、 3 と 4 の順番が逆になっています。この場合、same-fringe-p は #f を返します。
プログラムは次のようになります。
リスト : ツリーマッチング
(defun same-fringe-p (tree1 tree2 &key (test #'eql))
(labels ((iter (s1 s2)
(cond ((and (null s1) (null s2)) t)
((or (null s1) (null s2)) nil)
((funcall test (stream-car s1) (stream-car s2))
(iter (stream-cdr s1) (stream-cdr s2)))
(t nil))))
(iter (stream-of-tree tree1 #'(lambda () nil))
(stream-of-tree tree2 #'(lambda () nil)))))
実際の処理は局所関数 iter で行います。same-fringe-p は stream-of-tree で木の遅延ストリームを生成して iter に渡します。あとは、遅延ストリームから要素を一つずつ取り出して、それが等しいかチェックするだけです。
それでは実行例を示します。
* (same-fringe-p '(1 2 (3 4 (5 . 6) 7) 8) '(1 2 (3 4 (5 6) 7) 8)) T * (same-fringe-p '(1 2 (3 4 (5 . 6) 7) 8) '(1 2 (3 4 (6 5) 7) 8)) NIL
正常に動作していますね。
;;;
;;; lazy.l : 遅延評価と遅延ストリーム
;;;
;;; Copyright (C) 2008-2017 Makoto Hiroi
;;;
;;
;; 遅延評価
;;
(defmacro delay (expr)
`(make-promise #'(lambda () ,expr)))
(defun make-promise (f)
(let ((flag nil) (result nil))
#'(lambda ()
(unless flag
(let ((x (funcall f)))
(unless flag
(setf flag t
result x))))
result)))
(defun force (promise)
(funcall promise))
;;
;; 遅延ストリーム
;;
;; 遅延ストリームの生成
(defmacro stream-cons (a b)
`(cons ,a (delay ,b)))
(defun stream-car (s) (car s))
(defun stream-cdr (s) (force (cdr s)))
;; 整数列を生成
(defun range (low high)
(if (> low high)
nil
(stream-cons low (range (1+ low) high))))
;; フィボナッチ数列
(defun fibonacci (a b)
(stream-cons a (fibonacci b (+ a b))))
;; 無限ストリームの生成
(defun iterate (proc a)
(stream-cons a (iterate proc (funcall proc a))))
;; リストを遅延ストリームに変換
(defun list-to-stream (xs)
(if (null xs)
nil
(stream-cons (car xs) (list-to-stream (cdr xs)))))
;; n 番目の要素を求める
(defun stream-ref (s n)
(do ((s s (stream-cdr s))
(n n (1- n)))
((zerop n) (stream-car s))))
;; 先頭から n 個の要素を取り出す
(defun stream-take (s n)
(do ((s s (stream-cdr s))
(n n (1- n))
(a nil))
((or (null s) (zerop n)) (nreverse a))
(push (stream-car s) a)))
;; 先頭から n 個の要素を取り除く
(defun stream-drop (s n)
(do ((s s (stream-cdr s))
(n n (1- n)))
((or (null s) (zerop n)) s)))
;; ストリームの結合
(defun stream-append (s1 s2)
(if (null s1)
s2
(stream-cons (stream-car s1)
(stream-append (stream-cdr s1) s2))))
(defun interleave (s1 s2)
(if (null s1)
s2
(stream-cons (stream-car s1)
(interleave s2 (stream-cdr s1)))))
;; 遅延評価版
(defun stream-append-delay (s1 s2)
(if (null s1)
(force s2)
(stream-cons (stream-car s1)
(stream-append-delay (stream-cdr s1) s2))))
(defun interleave-delay (s1 s2)
(if (null s1)
(force s2)
(stream-cons (stream-car s1)
(interleave-delay (force s2) (cdr s1)))))
;;
;; 高階関数
;;
;; マップ関数
(defun stream-map (proc &rest s)
(if (member nil s)
nil
(stream-cons (apply proc (mapcar #'stream-car s))
(apply #'stream-map proc (mapcar #'stream-cdr s)))))
;; マッピングの結果を平坦化する
(defun stream-flatmap (proc s)
(if (null s)
nil
(stream-append-delay (funcall proc (stream-car s))
(delay (stream-flatmap proc (stream-cdr s))))))
;; フィルター
(defun stream-filter (pred s)
(cond ((null s) nil)
((funcall pred (stream-car s))
(stream-cons (stream-car s)
(stream-filter pred (stream-cdr s))))
(t (stream-filter pred (stream-cdr s)))))
;; 畳み込み
(defun stream-fold-left (proc a s)
(if (null s)
a
(stream-fold-left proc (funcall proc a (stream-car s)) (stream-cdr s))))
(defun stream-fold-right (proc a s)
(if (null s)
a
(funcall proc (stream-car s) (stream-fold-right proc a (stream-cdr s)))))
;; 巡回
(defun stream-for-each (proc s)
(cond ((not (null s))
(funcall proc (stream-car s))
(stream-for-each proc (stream-cdr s)))))
;;
(defun stream-take-while (pred s)
(do ((s s (stream-cdr s))
(a nil))
((not (funcall pred (stream-car s))) (nreverse a))
(push (stream-car s) a)))
;;
(defun stream-drop-while (pred s)
(do ((s s (stream-cdr s)))
((not (funcall pred (stream-car s))) s)))
;; 遅延ストリームの併合
(defun stream-merge (s1 s2)
(cond ((null s1) s2)
((null s2) s1)
(t
(if (<= (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1) (stream-merge (stream-cdr s1) s2))
(stream-cons (stream-car s2) (stream-merge s1 (stream-cdr s2)))))))
;;
;; 集合演算
;;
;; 和集合
(defun stream-union (s1 s2)
(cond ((null s1) s2)
((null s2) s1)
(t
(cond ((= (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1)
(stream-union (stream-cdr s1) (stream-cdr s2))))
((< (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1)
(stream-union (stream-cdr s1) s2)))
(t
(stream-cons (stream-car s2)
(stream-union s1 (stream-cdr s2))))))))
;; 積集合
(defun stream-intersect (s1 s2)
(cond ((or (null s1) (null s2)) nil)
((= (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1)
(stream-intersect (stream-cdr s1) (stream-cdr s2))))
((< (stream-car s1) (stream-car s2))
(stream-intersect (stream-cdr s1) s2))
(t
(stream-intersect s1 (stream-cdr s2)))))
;; 素数の生成
(defun sieve (s)
(stream-cons (stream-car s)
(sieve (stream-filter #'(lambda (x) (/= (mod x (stream-car s)) 0))
(stream-cdr s)))))
;; 別解
(defvar *primes* (stream-cons 2 (stream-cons 3 (stream-cons 5 (primes-from 7)))))
(defun primes-from (n)
(if (primep n)
(stream-cons n (primes-from (+ n 2)))
(primes-from (+ n 2))))
(defun primep (n)
(every #'(lambda (p) (/= (mod n p) 0))
(stream-take-while #'(lambda (p) (<= (* p p) n)) *primes*)))
;; 順列の生成
(defun make-perm (n s)
(if (zerop n)
(stream-cons nil nil)
(stream-flatmap
#'(lambda (x)
(stream-map #'(lambda (y) (cons x y))
(make-perm (1- n)
(stream-filter #'(lambda (z) (not (eql x z))) s))))
s)))
;; 8 Queen の解法
(defun attack (x xs)
(labels ((attack-sub (x n ys)
(cond ((null ys) t)
((or (= (+ (car ys) n) x)
(= (- (car ys) n) x))
nil)
(t (attack-sub x (1+ n) (cdr ys))))))
(attack-sub x 1 xs)))
(defun queen (s)
(if (null s)
(stream-cons nil nil)
(stream-filter
#'(lambda (ls)
(if (null ls)
t
(attack (car ls) (cdr ls))))
(stream-flatmap
#'(lambda (x)
(stream-map #'(lambda (y) (cons x y))
(queen (stream-filter #'(lambda (z) (not (eql x z))) s))))
s))))
;; 木の巡回 (リストを木としてみる)
(defun iter-tree (fn ls)
(cond ((null ls) nil)
((atom ls) (funcall fn ls))
(t (iter-tree fn (car ls))
(iter-tree fn (cdr ls)))))
(defun iter-tree-cps (fn ls cont)
(cond ((null ls) (funcall cont))
((atom ls)
(funcall fn ls)
(funcall cont))
(t (iter-tree-cps
fn
(car ls)
#'(lambda () (iter-tree-cps
fn
(cdr ls)
#'(lambda () (funcall cont))))))))
;;
(defun stream-of-tree (ls cont)
(cond ((null ls) (funcall cont))
((atom ls)
(stream-cons ls (funcall cont)))
(t (stream-of-tree
(car ls)
#'(lambda () (stream-of-tree
(cdr ls)
#'(lambda () (funcall cont))))))))
;; ツリーマッチング
(defun same-fringe-p (tree1 tree2 &key (test #'eql))
(labels ((iter (s1 s2)
(cond ((and (null s1) (null s2)) t)
((or (null s1) (null s2)) nil)
((funcall test (stream-car s1) (stream-car s2))
(iter (stream-cdr s1) (stream-cdr s2)))
(t nil))))
(iter (stream-of-tree tree1 #'(lambda () nil))
(stream-of-tree tree2 #'(lambda () nil)))))