次は、要素を昇順に出力する 2 つの遅延ストリームを併合 (マージ: merge) する関数を作りましょう。次のリストを見てください。
リスト : 遅延ストリームのマージ
;; 遅延ストリームの併合
(define (stream-merge s1 s2)
(cond
((stream-empty? s1) s2)
((stream-empty? s2) s1)
((<= (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1) (stream-merge (stream-cdr s1) s2)))
(else
(stream-cons (stream-car s2) (stream-merge s1 (stream-cdr s2))))))
stream-merge は 2 つの遅延ストリームを併合して新しい遅延ストリームを返します。s1 が空であれば s2 を返し、s2 が空ならば s1 を返します。そうでなければ、遅延ストリームの先頭要素を比較します。s1 の要素が s2 の要素以下ならば s1 の要素を、そうでなければ s2 の要素を遅延ストリームに格納します。
簡単な実行例を示しましょう。
gosh[r7rs.user]> (define s1 (stream-unfold (lambda (x) (+ x 2)) 1)) s1 gosh[r7rs.user]> (define s2 (stream-unfold (lambda (x) (+ x 2)) 2)) s2 gosh[r7rs.user]> (define s3 (stream-merge s1 s2)) s3 gosh[r7rs.user]> (stream->list (stream-take s3 20)) (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20) gosh[r7rs.user]> (stream->list (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)
ここで、遅延ストリームには重複要素が存在せず、要素は昇順に出力されることを前提にすると、遅延ストリームでも集合演算を行うことができます。次のリストを見てください。
リスト : 集合演算
;; 和集合
(define (stream-union s1 s2)
(cond
((stream-empty? s1) s2)
((stream-empty? s2) s1)
((< (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1)
(stream-union (stream-cdr s1) s2)))
((> (stream-car s1) (stream-car s2))
(stream-cons (stream-car s2)
(stream-union s1 (stream-cdr s2))))
(else
(stream-cons (stream-car s1)
(stream-union (stream-cdr s1) (stream-cdr s2))))))
;; 積集合
(define (stream-intersect s1 s2)
(cond
((or (stream-empty? s1) (stream-empty? 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))
(else
(stream-intersect s1 (stream-cdr s2)))))
stream-union は s1 と s2 から要素を取り出して、小さいほうを遅延ストリームに追加します。等しい場合は要素をひとつだけ追加します。このとき、s1 と s2 の両方から先頭要素を取り除くことに注意してください。
stream-intersect も簡単です。s1, s2 の先頭要素を比較して、等しい場合はその要素を遅延ストリームに追加します。s1 の要素が s2 の要素よりも小さい場合は、s1 を一つ進めて次の要素を調べます。s2 の要素が小さい場合は s2 の次の要素を調べます。
簡単な実行例を示しましょう。
gosh[r7rs.user]> (define xs (stream-scanl + 1 (stream-unfold (lambda (x) (+ x 1)) 2))) xs gosh[r7rs.user]> (stream->list (stream-take xs 20)) (1 3 6 10 15 21 28 36 45 55 66 78 91 105 120 136 153 171 190 210) gosh[r7rs.user]> (define ys (stream-map (lambda (x) (* x x)) (stream-unfold (lambda (x) (+ x 1)) 1))) ys gosh[r7rs.user]> (stream->list (stream-take ys 20)) (1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400) gosh[r7rs.user]> (stream->list (stream-take ys 20)) (1 4 9 16 25 36 49 64 81 100 121 144 169 196 225 256 289 324 361 400) gosh[r7rs.user]> (stream->list (stream-take (stream-intersect xs ys) 7)) (1 36 1225 41616 1413721 48024900 1631432881)
遅延ストリーム xs は「三角数」、ys は「四角数」を表します。これらの遅延ストリームを 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 から始まるので次のように定義できます。
(define 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 でひとつにまとめて、小さい順に出力すればいいわけです。
プログラムと実行結果を示します。
gosh[r7rs.user]> (define 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))))) hs gosh[r7rs.user]> (stream-for-each (lambda (x) (display x) (display " ")) (stream->list (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 #<undef>
次は遅延ストリームを使って順列を生成するプログラムを作ってみましょう。遅延ストリームを使う場合、再帰呼び出しの一番深いところで順列が完成するようにプログラムするとうまくいきません。要素が n 個の順列を生成する場合、n - 1 個の順列を生成するストリームを生成し、そこに要素を一つ加えて n 個の順列を生成すると考えます。
基本的には、拙作のページ 順列と組み合わせ で作成した、順列をリストに格納して返すプログラム [順列の生成 (4)] と同じです。このプログラムを遅延ストリームに対応させると次のようになります。
リスト : 遅延ストリームによる順列の生成
(define (stream-perm n s)
(if (zero? n)
(stream-cons '() nil)
(stream-flatmap
(lambda (x)
(stream-map (lambda (y) (cons x y))
(stream-perm
(- n 1)
(stream-filter (lambda (z) (not (eqv? x z))) s))))
s)))
関数 stream-perm はストリーム s の中から要素を n 個選ぶ順列を生成します。n = 0 の場合は空リストを格納したストリームを返します。あとは、stream-flatmap のラムダ式の中で、stream-perm を再帰呼び出しして n - 1 個を選ぶ順列を生成します。ストリーム s から要素 x を取り除くため、stream-filter を使っています。これで順列を生成するストリームを作ることができます。
それでは実際に試してみましょう。
gosh[r7rs.user]> (define s (stream-perm 4 (stream-range 1 4))) s gosh[r7rs.user]> (stream->list s) ((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 クイーンの解法 (遅延ストリーム版)
;; 衝突のチェック
(define (attack x xs)
(define (attack-sub x n ys)
(cond
((null? ys) #t)
((or (= (+ (car ys) n) x)
(= (- (car ys) n) x))
#f)
(else
(attack-sub x (+ n 1) (cdr ys)))))
(attack-sub x 1 xs))
;; N Queen の解法
(define (queen s)
(if (stream-empty? s)
(stream-cons '() (stream-empty))
(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 (eqv? x z))) s))))
s))))
関数 queen は stream-perm とほぼ同じですが、追加したクイーンが他のクイーンと衝突している場合は stream-filter を使って取り除いています。衝突をチェックする関数 attack は拙作のページ OCaml 入門：バックトラック法 の 8 クイーンで作成したプログラムを Scheme に直したものです。
それでは実行してみましょう。
gosh[r7rs.user]> (stream->list (stream-take (queen (stream-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) と考えます。木を巡回するプログラムは簡単です。次のリストを見てください。
リスト : 木の巡回
(define (for-each-tree fn ls)
(cond
((null? ls) '())
((not (pair? ls)) (fn ls))
(else
(for-each-tree fn (car ls))
(for-each-tree fn (cdr ls)))))
関数 for-each-tree は木 ls を巡回して、各要素に関数 fn を適用します。for-each-tree は関数 fn の副作用が目的なので、返り値に意味はありません。ls が空リストならば何もせずに空リストを返します。ls がアトムならば葉なので関数 fn を適用します。あとは、ls を car と cdr で分解して for-each-tree を再帰呼び出しするだけです。
このプログラムを CPS に変換すると、次のようになります。
リスト : 木の巡回 (CPS)
(define (for-each-tree-cps fn ls cont)
(cond
((null? ls) (cont))
((not (pair? ls))
(fn ls)
(cont))
(else
(for-each-tree-cps
fn
(car ls)
(lambda () (for-each-tree-cps fn (cdr ls) (lambda () (cont))))))))
for-each-tree-cps は副作用が目的なので、継続に値を渡す必要はありません。ls が空リストの場合は cont を呼び出します。ls が葉の場合は fn を適用してから cont を呼び出します。次に、for-each-tree-cps を再帰呼び出しして CAR の部分木をたどり、その継続の中で CDR の部分木をたどります。そして、その継続の中で cont を呼び出します。これで生成された継続を呼び出して、木を巡回することができます。
それでは実際に試してみましょう。
gosh[r7rs.user]> (for-each-tree-cps display '(a (b (c (d . e) f) g)) (lambda () '())) abcdefg()
このように、木を巡回して各要素に関数 fn を適用することができます。
木の巡回を CPS に変換すると、遅延ストリームに対応するのも簡単です。次のリストを見てください。
リスト : 木の巡回 (遅延ストリーム版)
(define (stream-of-tree ls cont)
(cond
((null? ls) (cont))
((not (pair? ls))
(stream-cons ls (cont)))
(else
(stream-of-tree
(car ls)
(lambda () (stream-of-tree (cdr ls) (lambda () (cont))))))))
stream-of-tree は木を巡回してその要素を順番に出力する遅延ストリームを生成します。stream-of-tree は ls が葉の場合に stream-cons で遅延ストリームを生成して返します。このとき、ls が遅延ストリームの要素になり、遅延オブジェクトには継続 cont の呼び出しを格納します。この遅延オブジェクトを force することで、次の要素を求めることができます。
なお、stream-of-tree を呼び出すときに渡す継続が一番最後に呼び出されるので、遅延ストリームの終端を返すように定義してください。
簡単な実行例を示しましょう。
gosh[r7rs.user]> (define trees (stream-of-tree '(a (b (c (d . e) f) g)) (lambda () (stream-empty)))) trees gosh[r7rs.user]> (stream->list trees) (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 を返します。
プログラムは次のようになります。
リスト : ツリーマッチング
(define (same-fringe-p tree1 tree2)
(define (iter s1 s2)
(cond
((and (stream-empty? s1) (stream-empty? s2)) #t)
((or (stream-empty? s1) (stream-empty? s2)) #f)
((eqv? (stream-car s1) (stream-car s2))
(iter (stream-cdr s1) (stream-cdr s2)))
(else #f)))
(iter (stream-of-tree tree1 (lambda () (stream-empty)))
(stream-of-tree tree2 (lambda () (stream-empty)))))
実際の処理は局所関数 iter で行います。same-fringe-p は stream-of-tree で木の遅延ストリームを生成して iter に渡します。あとは、遅延ストリームから要素を一つずつ取り出して、それが等しいかチェックするだけです。
それでは実行例を示します。
gosh[r7rs.user]> (same-fringe-p '(1 2 (3 4 (5 . 6) 7) 8) '(1 2 (3 4 (5 6) 7) 8)) #t gosh[r7rs.user]> (same-fringe-p '(1 2 (3 4 (5 . 6) 7) 8) '(1 2 (3 4 (6 5) 7) 8)) #f
正常に動作していますね。
遅延ストリームはプロミスを使わずにクロージャだけで実装することもできます。基本的な考え方は SRFI-127, R7RS-large (scheme lseq) と同じです。次のリストを見てください。
リスト : 遅延ストリーム (その２)
(define-library (mylib lazyseq)
(import (scheme base) (scheme lazy) (scheme case-lambda))
(export ・・・省略・・・ )
(begin
;; 遅延ストリームの生成
(define-syntax stream-cons
(syntax-rules ()
((_ a b) (cons a (lambda () b)))))
;; 先頭要素を参照
(define (stream-car s) (car s))
;; 先頭要素を取り除く
(define (stream-cdr s)
(when
(procedure? (cdr s))
(set-cdr! s ((cdr s))))
(cdr s))
・・・省略・・・
))
遅延ストリームをコンスセルで表すのは同じです。stream-cons では、プロミスのかわりにクロージャを CDR 部にセットします。stream-car は今までと同じです。そして、stream-cdr で遅延ストリーム s をたどるとき、(cdr s) が関数か述語 procedure? でチェックします。そうであれば (cdr s) を評価し、その返り値で s の CDR 部を破壊的に修正します。最後に (cdr s) を返します。
たとえば、s が (item1 . #<closure ...>) だとしましょう。((cdr s)) の返り値は遅延ストリームになります。それが (item2 . #<closure ...>) だとすると、これが s の CDR 部にセットされるので、遅延ストリームは次のようになります。
(item1 . #<closure ...>) == stream-cdr => (item1 item2 . #<closure ...>)
このように、クロージャの評価結果をリストに格納していくことで、効率的に遅延ストリームを実装することができます。
あとのプログラムは修正しなくても大丈夫です。詳細は プログラムリスト２ をお読みください。
簡単な実行例を示しましょう。
gosh[r7rs.user]> (define s1 (stream-range 1 4)) s1 gosh[r7rs.user]> s1 (1 . #<closure ((stream-range stream-range))>) gosh[r7rs.user]> (stream-cdr s1) (2 . #<closure ((stream-range stream-range))>) gosh[r7rs.user]> s1 (1 2 . #<closure ((stream-range stream-range))>) gosh[r7rs.user]> (stream-cdr (stream-cdr s1)) (3 . #<closure ((stream-range stream-range))>) gosh[r7rs.user]> s1 (1 2 3 . #<closure ((stream-range stream-range))>) gosh[r7rs.user]> (stream-cdr (stream-cdr (stream-cdr s1))) (4 . #<closure ((stream-range stream-range))>) gosh[r7rs.user]> s1 (1 2 3 4 . #<closure ((stream-range stream-range))>) gosh[r7rs.user]> (stream-cdr (stream-cdr (stream-cdr (stream-cdr s1)))) () gosh[r7rs.user]> s1 (1 2 3 4) gosh[r7rs.user]> (stream->list (stream-map (lambda (x y) (list x y)) (stream-unfold (lambda (x) (+ x 1)) 1) '(a b c d e))) ((1 a) (2 b) (3 c) (4 d) (5 e)) gosh[r7rs.user]> (define ps (stream-perm 8 (stream-range 1 8))) ps gosh[r7rs.user]> ps ((1 2 3 4 5 6 7 8) . #<closure ((stream-append-delay stream-append-delay))>) gosh[r7rs.user]> (stream-ref ps 20) (1 2 3 4 8 6 5 7) gosh[r7rs.user]> (stream->list (stream-take ps 21)) ((1 2 3 4 5 6 7 8) (1 2 3 4 5 6 8 7) (1 2 3 4 5 7 6 8) (1 2 3 4 5 7 8 6) (1 2 3 4 5 8 6 7) (1 2 3 4 5 8 7 6) (1 2 3 4 6 5 7 8) (1 2 3 4 6 5 8 7) (1 2 3 4 6 7 5 8) (1 2 3 4 6 7 8 5) (1 2 3 4 6 8 5 7) (1 2 3 4 6 8 7 5) (1 2 3 4 7 5 6 8) (1 2 3 4 7 5 8 6) (1 2 3 4 7 6 5 8) (1 2 3 4 7 6 8 5) (1 2 3 4 7 8 5 6) (1 2 3 4 7 8 6 5) (1 2 3 4 8 5 6 7) (1 2 3 4 8 5 7 6) (1 2 3 4 8 6 5 7)) gosh[r7rs.user]> *primes* (2 . #<closure (*primes*)>) gosh[r7rs.user]> (stream-ref *primes* 50) 233 gosh[r7rs.user]> *primes* (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 ....)
stream-map などの操作関数に普通のリストを渡すと、有限の遅延ストリームとして動作します。興味のある方はいろいろ試してみてください。
;;;
;;; lazystream.scm : 遅延ストリーム
;;;
;;; Copyright (C) 2009-2020 Makoto Hiroi
;;;
(define-library (mylib lazystream)
(import (scheme base) (scheme lazy) (scheme case-lambda))
(export stream-cons stream-car stream-cdr stream-empty? stream-empty
stream-range stream-unfold list->stream stream->list stream-ref
stream-take stream-drop stream-append stream-append-delay interleave
stream-map stream-flatmap stream-filter stream-foldl stream-foldr
stream-scanl stream-for-each stream-take-while stream-drop-while
stream-merge stream-union stream-intersect stream-perm
sieve *primes*
)
(begin
;; 遅延ストリームの生成
(define-syntax stream-cons
(syntax-rules ()
((_ a b) (cons a (delay b)))))
;; 先頭要素を参照
(define (stream-car s) (car s))
;; 先頭要素を取り除く
(define (stream-cdr s) (force (cdr s)))
;; ストリームの終端
(define nil '())
(define stream-empty? null?)
(define (stream-empty) nil)
;; 整数列の生成
(define (stream-range low high)
(if (> low high)
nil
(stream-cons low (stream-range (+ 1 low) high))))
;; 逆畳み込み
(define stream-unfold
(case-lambda
((iterate seed)
(stream-unfold iterate seed (lambda (x) #f)))
((iterate seed pred)
(if (pred seed)
nil
(stream-cons seed
(stream-unfold iterate (iterate seed) pred))))))
;; リストとストリームの変換
(define (list->stream xs)
(if (null? xs)
nil
(stream-cons (car xs) (list->stream (cdr xs)))))
(define (stream->list s)
(if (stream-empty? s)
'()
(cons (stream-car s) (stream->list (stream-cdr s)))))
;; 基本的な操作関数
(define (stream-ref s n)
(if (zero? n)
(stream-car s)
(stream-ref (stream-cdr s) (- n 1))))
(define (stream-take s n)
(if (or (stream-empty? s) (zero? n))
nil
(stream-cons (stream-car s)
(stream-take (stream-cdr s) (- n 1)))))
(define (stream-drop s n)
(if (or (stream-empty? s) (zero? n))
s
(stream-drop (stream-cdr s) (- n 1))))
;; ストリームの連結
(define (stream-append s1 s2)
(if (stream-empty? s1)
s2
(stream-cons (stream-car s1)
(stream-append (stream-cdr s1) s2))))
(define (interleave s1 s2)
(if (stream-empty? s1)
s2
(stream-cons (stream-car s1)
(interleave s2 (stream-cdr s1)))))
;; 遅延ストリームの連結 (遅延評価版)
(define (stream-append-delay s1 s2)
(if (stream-empty? s1)
(force s2)
(stream-cons (stream-car s1)
(stream-append-delay (stream-cdr s1) s2))))
;;
;; 高階関数
;;
;; マッピング
(define (map-1 proc s)
(if (stream-empty? s)
nil
(stream-cons (proc (stream-car s))
(map-1 proc (stream-cdr s)))))
(define (map-n proc ss)
(if (member nil ss)
nil
(stream-cons (apply proc (map stream-car ss))
(map-n proc (map stream-cdr ss)))))
(define stream-map
(case-lambda
((proc s)
(map-1 proc s))
((proc s . args)
(map-n proc (cons s args)))))
;; マッピングの結果を平坦化する
(define (stream-flatmap proc s)
(if (stream-empty? s)
nil
(stream-append-delay (proc (stream-car s))
(delay (stream-flatmap proc (stream-cdr s))))))
;; フィルター
(define (stream-filter pred s)
(cond
((stream-empty? s) nil)
((pred (stream-car s))
(stream-cons (stream-car s)
(stream-filter pred (stream-cdr s))))
(else
(stream-filter pred (stream-cdr s)))))
;; 畳み込み
(define (foldl-1 proc a s)
(if (stream-empty? s)
a
(foldl-1 proc (proc a (stream-car s)) (stream-cdr s))))
(define (foldl-n proc a ss)
(if (member nil ss)
a
(foldl-n proc
(apply proc a (map stream-car ss))
(map stream-cdr ss))))
(define stream-foldl
(case-lambda
((proc a s)
(foldl-1 proc a s))
((proc a s . args)
(foldl-n proc a (cons s args)))))
(define (foldr-1 proc a s)
(if (stream-empty? s)
a
(proc (foldr-1 proc a (stream-cdr s)) (stream-car s))))
(define (foldr-n proc a ss)
(if (member nil ss)
a
(apply proc
(foldr-n proc a (map stream-cdr ss))
(map stream-car ss))))
(define stream-foldr
(case-lambda
((proc a s)
(foldr-1 proc a s))
((proc a s . args)
(foldr-n proc a (cons s args)))))
(define (scanl-1 proc a s)
(if (stream-empty? s)
(stream-cons a nil)
(stream-cons a (scanl-1 proc (proc a (stream-car s)) (stream-cdr s)))))
(define (scanl-n proc a ss)
(if (member nil ss)
(stream-cons a nil)
(stream-cons a (scanl-n proc
(apply proc a (map stream-car ss))
(map stream-cdr ss)))))
(define stream-scanl
(case-lambda
((proc a s)
(scanl-1 proc a s))
((proc a s . args)
(scanl-n proc a (cons s args)))))
;; 巡回
(define (for-each-1 proc s)
(unless
(stream-empty? s)
(proc (stream-car s))
(for-each-1 proc (stream-cdr s))))
(define (for-each-n proc ss)
(unless
(member nil ss)
(apply proc (map stream-car ss))
(for-each-n proc (map stream-cdr ss))))
(define stream-for-each
(case-lambda
((proc s)
(for-each-1 proc s))
((proc s . args)
(for-each-n proc (cons s args)))))
;;
(define (stream-take-while pred s)
(if (or (stream-empty? s) (not (pred (stream-car s))))
nil
(stream-cons (stream-car s)
(stream-take-while pred (stream-cdr s)))))
(define (stream-drop-while pred s)
(if (or (stream-empty? s) (not (pred (stream-car s))))
s
(stream-drop-while pred (stream-cdr s))))
;; 遅延ストリームの併合
(define (stream-merge s1 s2)
(cond
((stream-empty? s1) s2)
((stream-empty? s2) s1)
((<= (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1) (stream-merge (stream-cdr s1) s2)))
(else
(stream-cons (stream-car s2) (stream-merge s1 (stream-cdr s2))))))
;; 和集合
(define (stream-union s1 s2)
(cond
((stream-empty? s1) s2)
((stream-empty? s2) s1)
((< (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1)
(stream-union (stream-cdr s1) s2)))
((> (stream-car s1) (stream-car s2))
(stream-cons (stream-car s2)
(stream-union s1 (stream-cdr s2))))
(else
(stream-cons (stream-car s1)
(stream-union (stream-cdr s1) (stream-cdr s2))))))
;; 積集合
(define (stream-intersect s1 s2)
(cond
((or (stream-empty? s1) (stream-empty? 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))
(else
(stream-intersect s1 (stream-cdr s2)))))
;; 順列の生成
(define (stream-perm n s)
(if (zero? n)
(stream-cons '() nil)
(stream-flatmap
(lambda (x)
(stream-map (lambda (y) (cons x y))
(stream-perm
(- n 1)
(stream-filter (lambda (z) (not (eqv? x z))) s))))
s)))
;;
;; 素数
;;
(define (sieve s)
(stream-cons (stream-car s)
(sieve (stream-filter
(lambda (x) (not (zero? (modulo x (stream-car s)))))
(stream-cdr s)))))
;; 高速化
(define *primes*
(stream-cons 2 (stream-cons 3 (stream-cons 5 (primes-from 7)))))
(define (primes-from n)
(if (prime? n)
(stream-cons n (primes-from (+ n 2)))
(primes-from (+ n 2))))
(define (prime? n)
(let loop ((s (stream-cdr *primes*)))
(let ((p (stream-car s)))
(cond
((> (* p p) n) #t)
((zero? (modulo n p)) #f)
(else
(loop (stream-cdr s)))))))
))
;;;
;;; lazyseq.scm : 遅延シーケンス
;;;
;;; Copyright (C) 2009-2020 Makoto Hiroi
;;;
(define-library (mylib lazyseq)
(import (scheme base) (scheme lazy) (scheme case-lambda))
(export stream-cons stream-car stream-cdr stream-empty? stream-empty
stream-range stream-unfold list->stream stream->list stream-ref
stream-take stream-drop stream-append stream-append-delay interleave
stream-map stream-flatmap stream-filter stream-foldl stream-foldr
stream-scanl stream-for-each stream-take-while stream-drop-while
stream-merge stream-union stream-intersect stream-perm
sieve *primes*
)
(begin
;; 遅延ストリームの生成
(define-syntax stream-cons
(syntax-rules ()
((_ a b) (cons a (lambda () b)))))
;; 先頭要素を参照
(define (stream-car s) (car s))
;; 先頭要素を取り除く
(define (stream-cdr s)
(when
(procedure? (cdr s))
(set-cdr! s ((cdr s))))
(cdr s))
;; ストリームの終端
(define nil '())
(define stream-empty? null?)
(define (stream-empty) nil)
;; 整数列の生成
(define (stream-range low high)
(if (> low high)
nil
(stream-cons low (stream-range (+ 1 low) high))))
;; 逆畳み込み
(define stream-unfold
(case-lambda
((iterate seed)
(stream-unfold iterate seed (lambda (x) #f)))
((iterate seed pred)
(if (pred seed)
nil
(stream-cons seed
(stream-unfold iterate (iterate seed) pred))))))
;; リストとストリームの変換
(define (list->stream xs)
(if (null? xs)
nil
(stream-cons (car xs) (list->stream (cdr xs)))))
(define (stream->list s)
(if (stream-empty? s)
'()
(cons (stream-car s) (stream->list (stream-cdr s)))))
;; 基本的な操作関数
(define (stream-ref s n)
(if (zero? n)
(stream-car s)
(stream-ref (stream-cdr s) (- n 1))))
(define (stream-take s n)
(if (or (stream-empty? s) (zero? n))
nil
(stream-cons (stream-car s)
(stream-take (stream-cdr s) (- n 1)))))
(define (stream-drop s n)
(if (or (stream-empty? s) (zero? n))
s
(stream-drop (stream-cdr s) (- n 1))))
;; ストリームの連結
(define (stream-append s1 s2)
(if (stream-empty? s1)
s2
(stream-cons (stream-car s1)
(stream-append (stream-cdr s1) s2))))
(define (interleave s1 s2)
(if (stream-empty? s1)
s2
(stream-cons (stream-car s1)
(interleave s2 (stream-cdr s1)))))
;; 遅延ストリームの連結 (遅延評価版)
(define (stream-append-delay s1 s2)
(if (stream-empty? s1)
(force s2)
(stream-cons (stream-car s1)
(stream-append-delay (stream-cdr s1) s2))))
;;
;; 高階関数
;;
;; マッピング
(define (map-1 proc s)
(if (stream-empty? s)
nil
(stream-cons (proc (stream-car s))
(map-1 proc (stream-cdr s)))))
(define (map-n proc ss)
(if (member nil ss)
nil
(stream-cons (apply proc (map stream-car ss))
(map-n proc (map stream-cdr ss)))))
(define stream-map
(case-lambda
((proc s)
(map-1 proc s))
((proc s . args)
(map-n proc (cons s args)))))
;; マッピングの結果を平坦化する
(define (stream-flatmap proc s)
(if (stream-empty? s)
nil
(stream-append-delay (proc (stream-car s))
(delay (stream-flatmap proc (stream-cdr s))))))
;; フィルター
(define (stream-filter pred s)
(cond
((stream-empty? s) nil)
((pred (stream-car s))
(stream-cons (stream-car s)
(stream-filter pred (stream-cdr s))))
(else
(stream-filter pred (stream-cdr s)))))
;; 畳み込み
(define (foldl-1 proc a s)
(if (stream-empty? s)
a
(foldl-1 proc (proc a (stream-car s)) (stream-cdr s))))
(define (foldl-n proc a ss)
(if (member nil ss)
a
(foldl-n proc
(apply proc a (map stream-car ss))
(map stream-cdr ss))))
(define stream-foldl
(case-lambda
((proc a s)
(foldl-1 proc a s))
((proc a s . args)
(foldl-n proc a (cons s args)))))
(define (foldr-1 proc a s)
(if (stream-empty? s)
a
(proc (foldr-1 proc a (stream-cdr s)) (stream-car s))))
(define (foldr-n proc a ss)
(if (member nil ss)
a
(apply proc
(foldr-n proc a (map stream-cdr ss))
(map stream-car ss))))
(define stream-foldr
(case-lambda
((proc a s)
(foldr-1 proc a s))
((proc a s . args)
(foldr-n proc a (cons s args)))))
(define (scanl-1 proc a s)
(if (stream-empty? s)
(stream-cons a nil)
(stream-cons a (scanl-1 proc (proc a (stream-car s)) (stream-cdr s)))))
(define (scanl-n proc a ss)
(if (member nil ss)
(stream-cons a nil)
(stream-cons a (scanl-n proc
(apply proc a (map stream-car ss))
(map stream-cdr ss)))))
(define stream-scanl
(case-lambda
((proc a s)
(scanl-1 proc a s))
((proc a s . args)
(scanl-n proc a (cons s args)))))
;; 巡回
(define (for-each-1 proc s)
(unless
(stream-empty? s)
(proc (stream-car s))
(for-each-1 proc (stream-cdr s))))
(define (for-each-n proc ss)
(unless
(member nil ss)
(apply proc (map stream-car ss))
(for-each-n proc (map stream-cdr ss))))
(define stream-for-each
(case-lambda
((proc s)
(for-each-1 proc s))
((proc s . args)
(for-each-n proc (cons s args)))))
;;
(define (stream-take-while pred s)
(if (or (stream-empty? s) (not (pred (stream-car s))))
nil
(stream-cons (stream-car s)
(stream-take-while pred (stream-cdr s)))))
(define (stream-drop-while pred s)
(if (or (stream-empty? s) (not (pred (stream-car s))))
s
(stream-drop-while pred (stream-cdr s))))
;; 遅延ストリームの併合
(define (stream-merge s1 s2)
(cond
((stream-empty? s1) s2)
((stream-empty? s2) s1)
((<= (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1) (stream-merge (stream-cdr s1) s2)))
(else
(stream-cons (stream-car s2) (stream-merge s1 (stream-cdr s2))))))
;; 和集合
(define (stream-union s1 s2)
(cond
((stream-empty? s1) s2)
((stream-empty? s2) s1)
((< (stream-car s1) (stream-car s2))
(stream-cons (stream-car s1)
(stream-union (stream-cdr s1) s2)))
((> (stream-car s1) (stream-car s2))
(stream-cons (stream-car s2)
(stream-union s1 (stream-cdr s2))))
(else
(stream-cons (stream-car s1)
(stream-union (stream-cdr s1) (stream-cdr s2))))))
;; 積集合
(define (stream-intersect s1 s2)
(cond
((or (stream-empty? s1) (stream-empty? 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))
(else
(stream-intersect s1 (stream-cdr s2)))))
;; 順列の生成
(define (stream-perm n s)
(if (zero? n)
(stream-cons '() nil)
(stream-flatmap
(lambda (x)
(stream-map (lambda (y) (cons x y))
(stream-perm
(- n 1)
(stream-filter (lambda (z) (not (eqv? x z))) s))))
s)))
;;
;; 素数
;;
(define (sieve s)
(stream-cons (stream-car s)
(sieve (stream-filter
(lambda (x) (not (zero? (modulo x (stream-car s)))))
(stream-cdr s)))))
;; 高速化
(define *primes*
(stream-cons 2 (stream-cons 3 (stream-cons 5 (primes-from 7)))))
(define (primes-from n)
(if (prime? n)
(stream-cons n (primes-from (+ n 2)))
(primes-from (+ n 2))))
(define (prime? n)
(let loop ((s (stream-cdr *primes*)))
(let ((p (stream-car s)))
(cond
((> (* p p) n) #t)
((zero? (modulo n p)) #f)
(else
(loop (stream-cdr s)))))))
))