前回まで作成した遅延ストリームは、stream-cons で遅延ストリームを生成するとき、ストリームの要素となる引数を評価していました。たとえば、(stream-cons (func x) ...) とすると、(func x) を評価した値がストリームの要素となります。ここで、ストリームにまだアクセスしていないのに、(func x) が評価されていることに注意してください。もし、(func x) がデータの入力処理だとすると、遅延ストリームを生成するときにデータをひとつ先読みしてしまうことになります。
そこで、コンスセルの CAR 部と CDR 部をまとめて遅延評価することにします。この場合、プロミスが遅延ストリームを表すことになります。今回はこの方法で遅延ストリームを作ってみましょう。
遅延ストリームをプロミスで表す場合、その構造はつぎのようになります。
リスト : 遅延ストリーム
;; プロミスが遅延ストリームを表す
(define-syntax stream-cons
(syntax-rules ()
((_ a b) (delay (cons a b)))))
;; 先頭要素を取り出す
(define (stream-car s) (car (force s)))
;; 先頭要素を取り除く
(define (stream-cdr s) (cdr (force s)))
;; ストリームの終端
(define nil (delay '()))
(define (empty? s) (null? (force s)))
stream-cons は (cons a (delay b)) ではなく (delay (cons a b)) とします。これで stream-cons の引数 a, b が遅延評価されます。stream-car と stream-cdr は遅延ストリーム s を force で評価してから car と cdr を適用します。遅延ストリームはプロミスで表すので、終端 nil の定義は (delay '()) とします。empty? も遅延ストリーム s を force で評価してから null? でチェックします。
ここで empty? を評価すると、遅延ストリームが force されることに注意してください。たとえば、遅延ストリームを連結する stream-append を次のように定義すると問題が発生します。
リスト : 遅延ストリームの連結 (間違い版)
;; 整数列の生成
(define (range low high)
(if (> low high)
nil
(stream-cons low
(range (+ 1 low) high))))
;; 遅延ストリームの連結 (間違い版)
(define (stream-append-bad s1 s2)
(if (empty? s1)
s2
(stream-cons (stream-car s1)
(stream-append-bad (stream-cdr s1) s2))))
stream-append-bad でストリームを生成するとき、empty? で s1 が force されることになります。つまり、新しいストリームを生成する前に引数のストリームが評価されてしまうのです。次の例を見てください。
gosh> (define s1 (range 1 4)) s1 gosh> (define s2 (range 5 8)) s2 gosh> (define s3 (stream-append-bad s1 s2)) s3 gosh> s1 #<promise ... (forced)> gosh> s2 #<promise ...> gosh> s3 #<promise ...>
s1 と s2 を連結した新しいストリーム s3 を評価していないにもかかわらず、引数のストリーム s1 が force されていることがわかります。この場合、stream-append の本体を delay と force で囲みます。
リスト : 遅延ストリームの連結 (修正版)
(define (stream-append s1 s2)
(delay
(force
(if (empty? s1)
s2
(stream-cons (stream-car s1)
(stream-append (stream-cdr s1) s2))))))
delay と force で囲むのは無駄なように思いますが、これにより stream-append を評価して遅延ストリームを生成するとき、引数 s1 の遅延ストリームが force されずにすむわけです。
実際には、次に示すようなマクロを定義すると簡単です。
リスト : 式 expr の遅延ストリームを返す
(define-syntax stream-delay
(syntax-rules ()
((_ expr) (delay (force expr)))))
リスト : 遅延ストリームの連結 (完成版)
(define (stream-append s1 s2)
(stream-delay
(if (empty? s1)
s2
(stream-cons (stream-car s1)
(stream-append (stream-cdr s1) s2)))))
簡単な実行例を示します。
gosh> (define s4 (range 1 4)) s4 gosh> (define s5 (range 5 8)) s5 gosh> (define s6 (stream-append s4 s5)) s6 gosh> s4 #<promise ...> gosh> s5 #<promise ...> gosh> s6 #<promise ...> gosh> (stream-car s6) 1 gosh> (stream-car (stream-cdr s6)) 2 gosh> (stream-car (stream-cdr (stream-cdr s6))) 3 gosh> (stream-car (stream-cdr (stream-cdr (stream-cdr s6)))) 4 gosh> (stream-car (stream-cdr (stream-cdr (stream-cdr (stream-cdr s6))))) 5
このように、stream-delay を使うことで、新しい遅延ストリームを生成するとき、引数のストリームが force されるのを防止することができます。
同様に stream-map や stream-filter など、遅延ストリームを受け取って新しい遅延ストリームを返す関数は stream-delay で囲む必要があります。詳細は プログラムリスト をお読みください。
それでは簡単な実行例として、素数を求めるプログラムで実行速度を比較してみましょう。
リスト : 素数を求める
(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)
(every (lambda (p) (not (zero? (modulo n p))))
(stream-take-while (lambda (p) (<= (* p p) n)) primes)))
素数列 primes の定義は 遅延ストリーム (1) で作成したものと同じです。(stream-ref primes 5000) の実行時間を求めたところ、結果は次のようになりました。
lazystream.scm : 0.34 秒 lazystream1.scm : 0.45 秒 実行環境 : Windows 7, Core i7-2670QM 2.20GHz
今回の遅延ストリームのほうが少し遅くなりました。興味のある方はいろいろ試してみてください。
今回は単純に delay と force を使いましたが、この方法では末尾再帰的なアルゴリズムとの相性がよくないことがわかっているそうです。詳しい説明は Gauche のリファレンス 遅延評価 や Yutaka Hara さんの R7RSのdelay-forceとは何か をお読みください。
ところで、Scheme には遅延ストリームを扱うライブラリ SRFI-40 があり、Gauche でも (use util.stream) で使用することができます。下記に基本的な操作関数を示します。
stream-take が遅延ストリームを返すことに注意してください。リストに変換するには関数 stream->list を使ってください。このほかにも便利な関数が多数用意されています。詳細は Gauche のリファレンス 12.67 util.stream - ストリームライブラリ をお読みくださいませ。
簡単な実行例を示します。
gosh> (use util.stream) gosh> (define a (stream-cons 1 stream-null)) a gosh> (define b (stream-cons 2 a)) b gosh> (define c (stream-cons 3 b)) c gosh> a #<promise(stream) ...> gosh> b #<promise(stream) ...> gosh> c #<promise(stream) ...> gosh> (stream-car c) 3 gosh> (stream-car (stream-cdr c)) 2 gosh> (stream-car (stream-cdr (stream-cdr c))) 1 gosh> (stream-cdr (stream-cdr (stream-cdr c))) #<promise(stream) ...> gosh> (stream-null? (stream-cdr (stream-cdr (stream-cdr c)))) #t gosh> (define (range n m) (if (> n m) stream-null (stream-cons n (range (+ n 1) m)))) range gosh> (define s (range 1 10)) s gosh> (stream-take s 10) #<promise(stream) ...> gosh> (stream->list s) (1 2 3 4 5 6 7 8 9 10) gosh> (define (add-stream s1 s2) (stream-map + s1 s2)) add-stream gosh> (define s1 (add-stream (range 1 10) (range 11 20))) s1 gosh> (stream->list s1) (12 14 16 18 20 22 24 26 28 30) gosh> (define fibo (stream-cons 0 (stream-cons 1 (add-stream (stream-cdr fibo) fibo)))) fibo gosh> (stream->list (stream-take fibo 40)) (0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946 17711 28657 46368 75025 121393 196418 317811 514229 832040 1346269 2178309 3524578 5702887 9227465 14930352 24157817 39088169 63245986)
リスト : 素数の生成 (lazysieve.scm)
(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)
(stream-every (lambda (p) (not (zero? (modulo n p))))
(stream-take-while (lambda (p) (<= (* p p) n)) primes)))
gosh> (stream->list (stream-take (stream-iota -1 1) 10)) (1 2 3 4 5 6 7 8 9 10) gosh> (stream->list (stream-take (sieve (stream-iota -1 2)) 25)) (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) gosh> (stream->list (stream-take primes 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) gosh> (time (stream-car (stream-drop primes 5000))) ;(time (stream-car (stream-drop primes 5000))) ; real 2.260 ; user 1.903 ; sys 1.061 48619 実行環境 : Windows 7, Core i7-2670QM 2.20GHz
リスト : 順列の生成と８クイーン (lazyperm.scm)
;; ストリームの連結 (遅延評価版)
(define (stream-append-delay s1 s2)
(stream-delay
(if (stream-null? s1)
(force s2)
(stream-cons (stream-car s1)
(stream-append-delay (stream-cdr s1) s2)))))
;; stream-map の結果を平坦化する
(define (stream-flatmap proc s)
(stream-delay
(if (stream-null? s)
stream-null
(stream-append-delay (proc (stream-car s))
(delay (stream-flatmap proc (stream-cdr s)))))))
;; 順列の生成
(define (make-perm n s)
(if (zero? n)
(stream-cons '() stream-null)
(stream-flatmap
(lambda (x)
(stream-map (lambda (y) (cons x y))
(make-perm
(- n 1)
(stream-filter (lambda (z) (not (eqv? x z))) s))))
s)))
;;
;; ８クイーンの解法 (遅延ストリーム版)
;;
;; 衝突のチェック
(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)
(stream-delay
(if (stream-null? s)
(stream-cons '() stream-null)
(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)))))
gosh> (define s (make-perm 4 (stream 1 2 3 4))) s gosh> (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) ) gosh> (define qs (queen (stream-iota 8 1))) qs gosh> (stream->list (stream-take qs 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))
遅延ストリームを扱う場合、Gauche にはもう一つ「遅延シーケンス」という便利な機能があります。Gauche のリファレンス 遅延シーケンス より引用します。
『遅延シーケンスはリストのようなデータ構造ですが、要素は必要になるまで計算されません。内部的には、これはcdrの評価が遅延される特別な種類のペアを使って実現されています。しかし、Schemeのレベルで「遅延ペア」のような特別なデータ型が見えることは決してありません。遅延ペアにアクセスしようとした途端、Gaucheは自動的に遅延されていた計算をforceして、遅延ペアは通常のペアに変化してしまうからです。』
Gauche の遅延シーケンスは通常のリスト操作関数に渡すことができるので便利です。たとえば、先頭要素を取り出すには car で、先頭要素を取り除くのも cdr で行うことができます。また、空のシーケンスは '() で表されるので、そのチェックは null? で行うことができます。
ただし、REPL で無限シーケンスを評価すると、その結果を表示する、つまり無限リストを生成しようとするため、Guache がフリーズしてしまいます。それから、Gauche の遅延シーケンスは、常にひとつ余分に評価します。自分自身を参照する遅延データ構造を作成するときには注意してください。詳細は Gauche のリファレンスをお読みくださいませ。
モジュール gauche.lazy には遅延シーケンス用の便利な関数が定義されているので、遅延シーケンスを使うときは (use gauche.lazy) してください。基本的な関数を以下に示します。
このほかにも便利な関数が多数用意されています。詳細は Gauche のリファレンス 9.13 gauche.lazy - 遅延シーケンスユーティリティ をお読みくださいませ。
簡単な実行例を示します。
gosh> (define a (lcons 1 '())) a gosh> (define b (lcons 2 a)) b gosh> (define c (lcons 3 b)) c gosh> a (1) gosh> b (2 1) gosh> c (3 2 1) gosh> (car c) 3 gosh> (cadr c) 2 gosh> (caddr c) 1 gosh> (null? (cdddr c)) #t gosh> (define s (lrange 1 11)) s gosh> (take s 10) (1 2 3 4 5 6 7 8 9 10) gosh> s (1 2 3 4 5 6 7 8 9 10) gosh> (define (add-stream s1 s2) (lmap + s1 s2)) add-stream gosh> (define s1 (add-stream (lrange 1 10) (lrange 11 20))) s1 gosh> s1 (12 14 16 18 20 22 24 26 28) gosh> (define s1 (add-stream (lrange 1 11) (lrange 11 21))) s1 gosh> s1 (12 14 16 18 20 22 24 26 28 30) gosh> (define fibo (lcons 0 (lcons 1 (add-stream (cdr fibo) fibo)))) fibo gosh> (take fibo 40) *** ERROR: Attempt to recursively force a lazy pair. gosh> (define fibo (lcons 0 (lcons 1 (lcons 1 (lmap (lambda (x y) (+ y (* x 2))) (cdr fibo) fibo))))) fibo gosh> (take fibo 40) (0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946 17711 28657 46368 75025 121393 196418 317811 514229 832040 1346269 2178309 3524578 5702887 9227465 14930352 24157817 39088169 63245986)
リスト : 素数の生成 (lseq1.scm)
(use gauche.lazy)
;; 素数の生成
(define (sieve s)
(lcons (car s)
(sieve (lfilter
(lambda (x) (not (zero? (modulo x (car s)))))
(cdr s)))))
(define primes (lcons 2 (lcons 3 (lcons 5 (primes-from 7)))))
(define (primes-from n)
(if (prime? n)
(lcons n (primes-from (+ n 2)))
(primes-from (+ n 2))))
(define (prime? n)
(every (lambda (p) (not (zero? (modulo n p))))
(ltake-while (lambda (p) (<= (* p p) n)) primes)))
gosh> (define s (lrange 2)) s gosh> (take s 10) (2 3 4 5 6 7 8 9 10 11) gosh> (define s (sieve (lrange 2))) s gosh> (take s 25) (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) gosh> (take primes 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) gosh> (time (car (drop primes 5000))) ;(time (car (drop primes 5000))) ; real 0.218 ; user 0.249 ; sys 0.016 48619 実行環境 : Windows 7, Core i7-2670QM 2.20GHz
リスト : 順列の生成と８クイーンの解法 (lseq2.scm)
(use gauche.lazy)
;; lmap の結果を平坦化する
(define (lflatmap proc s)
(lconcatenate (lmap proc s)))
;; 順列の生成
(define (make-perm n s)
(if (zero? n)
(lcons '() '())
(lflatmap
(lambda (x)
(lmap (lambda (y) (cons x y))
(make-perm
(- n 1)
(lfilter (lambda (z) (not (eqv? x z))) s))))
s)))
;;
;; ８クイーンの解法 (遅延ストリーム版)
;;
;; 衝突のチェック
(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 (null? s)
(lcons '() '())
(lfilter
(lambda (ls)
(if (null? ls)
#t
(attack (car ls) (cdr ls))))
(lflatmap
(lambda (x)
(lmap (lambda (y) (cons x y))
(queen (lfilter (lambda (z) (not (eqv? x z))) s))))
s))))
gosh> (define s (make-perm 4 (lcons* 1 2 3 4 '()))) s gosh> 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) ) gosh> (liota 8 1) (1 2 3 4 5 6 7 8) gosh> (define qs (queen (liota 8 1))) qs gosh> (take qs 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))
;;
;; lazystream1.scm : 遅延ストリーム (CAR 部も遅延評価する)
;;
;; Copyright (C) 2017 Makoto Hiroi
;;
(use srfi-1)
;; プロミスが遅延ストリームを表す
;; 遅延ストリームの基本関数
(define-syntax stream-cons
(syntax-rules ()
((_ a b) (delay (cons a b)))))
;; 先頭要素を取り出す
(define (stream-car s) (car (force s)))
;; 先頭要素を取り除く
(define (stream-cdr s) (cdr (force s)))
;; ストリームの終端
(define nil (delay '()))
(define (empty? s) (null? (force s)))
;; 式 expr の遅延ストリームを返す
(define-syntax stream-delay
(syntax-rules ()
((_ expr) (delay (force expr)))))
;;
;; ストリームの生成
;;
;; 数列を生成するストリーム
(define (range low high)
(if (> low high)
nil
(stream-cons low
(range (+ 1 low) high))))
;; フィボナッチ数列を生成する遅延ストリーム
(define (fibonacci a b)
(stream-cons a (fibonacci b (+ a b))))
;; 初項が a で次項を proc で生成する
(define (iterate proc a)
(stream-cons a (iterate proc (proc a))))
;; リストを遅延ストリームに変換する
(define (list->stream xs)
(if (null? xs)
nil
(stream-cons (car xs) (list->stream (cdr xs)))))
;;
;; 操作関数
;;
;; n 番目の要素を求める
(define (stream-ref s n)
(if (zero? n)
(stream-car s)
(stream-ref (stream-cdr s) (- n 1))))
;; 先頭から n 個の要素を取り出す
(define (stream-take s n)
(let loop ((s s) (n n) (a '()))
(if (or (zero? n) (empty? s))
(reverse! a)
(loop (stream-cdr s) (- n 1) (cons (stream-car s) a)))))
;; 先頭から n 個の要素を取り除く
(define (stream-drop s n)
(stream-delay
(if (or (zero? n) (empty? s))
s
(stream-drop (stream-cdr s) (- n 1)))))
;; 遅延ストリームの連結
(define (stream-append s1 s2)
(stream-delay
(if (empty? s1)
s2
(stream-cons (stream-car s1)
(stream-append (stream-cdr s1) s2)))))
;; 間違い版
(define (stream-append-bad s1 s2)
(if (empty? s1)
s2
(stream-cons (stream-car s1)
(stream-append-bad (stream-cdr s1) s2))))
;; 遅延評価版
(define (stream-append-delay s1 s2)
(stream-delay
(if (empty? s1)
(force s2)
(stream-cons (stream-car s1)
(stream-append-delay (stream-cdr s1) s2)))))
;; ストリームの要素を交互に出力
(define (interleave s1 s2)
(stream-delay
(if (empty? s1)
s2
(stream-cons (stream-car s1)
(interleave s2 (stream-cdr s1))))))
;;
;; 高階関数
;;
;; マッピング
(define (stream-map proc . s)
(stream-delay
(if (any empty? s)
nil
(stream-cons (apply proc (map stream-car s))
(apply stream-map proc (map stream-cdr s))))))
;; stream-map の結果を平坦化する
(define (stream-flatmap proc s)
(stream-delay
(if (empty? s)
nil
(stream-append-delay (proc (stream-car s))
(delay (stream-flatmap proc (stream-cdr s)))))))
;; フィルター
(define (stream-filter pred s)
(stream-delay
(cond ((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 (stream-fold-left proc a s)
(if (empty? s)
a
(stream-fold-left proc (proc a (stream-car s)) (stream-cdr s))))
(define (stream-fold-right proc a s)
(if (empty? s)
a
(proc (stream-car s) (stream-fold-right proc a (stream-cdr s)))))
;; 巡回
(define (stream-for-each proc s)
(cond ((not (empty? s))
(proc (stream-car s))
(stream-for-each proc (stream-cdr s)))))
;; 述語 pred が真を返す要素を取り出す
(define (stream-take-while pred s)
(let loop ((s s) (a '()))
(if (or (empty? s) (not (pred (stream-car s))))
(reverse! a)
(loop (stream-cdr s) (cons (stream-car s) a)))))
;; 述語 pred が真を返す要素を取り除く
(define (stream-drop-while pred s)
(stream-delay
(if (or (not (pred (stream-car s))) (empty? s))
s
(stream-drop-while pred (stream-cdr s)))))
;; 遅延ストリームの併合
(define (stream-merge s1 s2)
(stream-delay
(cond ((empty? s1) s2)
((empty? s2) s1)
(else
(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))))))))
;; 集合演算
;; 和集合
(define (stream-union s1 s2)
(stream-delay
(cond ((empty? s1) s2)
((empty? s2) s1)
(else
(cond ((< (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)
(stream-delay
(cond ((or (empty? s1) (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 (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)
(every (lambda (p) (not (zero? (modulo n p))))
(stream-take-while (lambda (p) (<= (* p p) n)) primes)))
;; 順列の生成
(define (make-perm n s)
(if (zero? n)
(stream-cons '() nil)
(stream-flatmap
(lambda (x)
(stream-map (lambda (y) (cons x y))
(make-perm
(- n 1)
(stream-filter (lambda (z) (not (eqv? x z))) s))))
s)))
;;
;; ８クイーンの解法 (遅延ストリーム版)
;;
;; 衝突のチェック
(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)
(stream-delay
(if (empty? s)
(stream-cons '() 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 (eqv? x z))) s))))
s)))))
;; 木の巡回 (遅延ストリーム版)
(define (stream-of-tree ls cont)
(stream-delay
(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)))))))))
;; ツリーマッチング
(define (same-fringe-p tree1 tree2)
(define (iter s1 s2)
(cond ((and (empty? s1) (empty? s2)) #t)
((or (empty? s1) (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 () nil))
(stream-of-tree tree2 (lambda () nil))))
gosh> (define (add-stream s1 s2) (stream-map (lambda (x y) (+ x y)) s1 s2)) add-stream gosh> (define s1 (range 1 10)) s1 gosh> (define s2 (range 11 20)) s2 gosh> (define s3 (add-stream s1 s2)) s3 gosh> s1 #<promise ...> gosh> s2 #<promise ...> gosh> s3 #<promise ...> gosh> (stream-take s3 10) (12 14 16 18 20 22 24 26 28 30) gosh> (define fibo (stream-cons 0 (stream-cons 1 (add-stream (stream-cdr fibo) fibo)))) fibo gosh> (stream-take fibo 40) (0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987 1597 2584 4181 6765 10946 17711 28657 46368 75025 121393 196418 317811 514229 832040 1346269 2178309 3524578 5702887 9227465 14930352 24157817 39088169 63245986) gosh> (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> (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) gosh> (define s (make-perm 4 (range 1 4))) s gosh> (stream-take s 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) ) gosh> (define qs (queen (range 1 8))) qs gosh> (stream-take qs 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)) gosh> (same-fringe-p '(1 2 (3 4 (5 . 6) 7) 8) '(1 2 (3 4 (5 6) 7) 8)) #t gosh> (same-fringe-p '(1 2 (3 4 (5 . 6) 7) 8) '(1 2 (3 4 (6 5) 7) 8)) #f