λ3.5節
問題 3.50
問題 3.51
問題 3.52
問題 3.53
問題 3.54
問題 3.55
問題 3.56
問題 3.57
問題 3.58
問題 3.59
問題 3.60
問題 3.61
問題 3.62
問題 3.63
問題 3.64
問題 3.65
問題 3.66
問題 3.67
問題 3.68
問題 3.69
問題 3.70
問題 3.71
問題 3.72
問題 3.73
問題 3.74
問題 3.75
問題 3.76
問題 3.77
問題 3.78
問題 3.79
問題 3.80
問題 3.81
問題 3.82
ストリーム
ストリーム
;; streams.scmとして読み込む.
(define (stream-enumerate-interval low high)
(if (> low high)
the-empty-stream
(cons-stream
low
(stream-enumerate-interval (+ low 1) high))))
(define (stream-ref s n)
(if (= n 0)
(stream-car s)
(stream-ref (stream-cdr s) (- n 1))))
(define (stream-filter pred stream)
(cond ((stream-null? stream) the-empty-stream)
((pred (stream-car stream))
(cons-stream (stream-car stream)
(stream-filter pred
(stream-cdr stream))))
(else (stream-filter pred (stream-cdr stream)))))
(define (stream-map proc . argstreams)
(if (stream-null? (car argstreams))
the-empty-stream
(cons-stream
(apply proc (map stream-car argstreams))
(apply stream-map
(cons proc (map stream-cdr argstreams))))))
(define (stream-for-each proc s)
(if (stream-null? s)
'done
(begin (proc (stream-car s))
(stream-for-each proc (stream-cdr s)))))
(define (display-stream s)
(stream-for-each display-line s))
(define (display-line x)
(newline)
(display x))
問題 3.50
(load "streams.scm")
;;一般化したstream-mapはstreams.scmの中にある.
(display-stream (stream-map (lambda (x y) (* x y))
(stream-enumerate-interval 0 10) (stream-enumerate-interval 10 20)))
問題 3.51
(load "streams.scm")
(define (show x)
(display-line x)
x)
(define x (stream-map show (stream-enumerate-interval 0 10)))
(stream-ref x 5)
(stream-ref x 7)
問題 3.52
(load "streams.scm")
(define sum 0)
(define (accum x)
(set! sum (+ x sum))
sum)
(define seq (stream-map accum (stream-enumerate-interval 1 20)))
(define y (stream-filter even? seq))
(define z (stream-filter (lambda (x) (= (remainder x 5) 0))
seq))
(stream-ref y 7)
(display-stream z)
問題 3.53
;実行してみなくても容易に分るが, 実行してみると:
(load "streams.scm")
(define (add-streams s1 s2)
(stream-map + s1 s2))
(define s (cons-stream 1 (add-streams s s)))
(display-stream s)
1
2
4
8
16
32
64
128
256
512
1024
...
問題 3.54
(load "streams.scm")
(define (mul-streams s1 s2) (stream-map * s1 s2))
(define (add-streams s1 s2) (stream-map + s1 s2))
(define ones (cons-stream 1 ones))
(define integers (cons-stream 1 (add-streams ones integers)))
(define factorials
(cons-stream 1 (mul-streams factorials (stream-cdr integers))))
(display-stream factorials)
問題 3.55
(load "streams.scm")
(define (add-streams s1 s2) (stream-map + s1 s2))
(define ones (cons-stream 1 ones))
(define integers (cons-stream 1 (add-streams ones integers)))
(define (partial-sums s)
(define s1 (cons-stream (stream-car s) (add-streams (stream-cdr s) s1)))
s1)
(display-stream (partial-sums integers))
問題 3.56
(load "streams.scm")
(define (merge s1 s2)
(cond ((stream-null? s1) s2)
((stream-null? s2) s1)
(else
(let ((s1car (stream-car s1))
(s2car (stream-car s2)))
(cond ((< s1car s2car)
(cons-stream s1car (merge (stream-cdr s1) s2)))
((> s1car s2car)
(cons-stream s2car (merge s1 (stream-cdr s2))))
(else
(cons-stream s1car
(merge (stream-cdr s1)
(stream-cdr s2)))))))))
(define (*3 x) (* 3 x))
(define (*5 x) (* 5 x))
(define (*7 x) (* 7 x))
(define S (cons-stream 1 (merge (stream-map *3 S)
(merge (stream-map *5 S)
(stream-map *7 S)))))
(display-stream S)
1
3
5
7
9
15
21
25
27
35
45
49
63
75
81
105
125
135
147
175
189
問題 3.58
(load "streams.scm")
(define (expand num den radix)
(cons-stream
(quotient (* num radix) den)
(expand (remainder (* num radix) den) den radix)))
(display-stream (expand 1 7 10))
1
4
2
8
5
7
1
4
2
8
5
7
1
4
2
8
5
7
1
4
(display-stream (expand 3 8 10))
3
7
5
0
0
0
0
0
0
0
num を den で割った radix進法の商を出力する.
問題 3.59
(load "streams.scm")
(define (integrate-series coefs)
(let ((n 0))
(stream-map (lambda (x) (set! n (+ n 1)) (/ x n)) coefs)))
(define exp-series (cons-stream 1 (integrate-series exp-series)))
;(display-stream exp-series)
(define cosine-series
(cons-stream 1 (stream-map - (integrate-series sine-series))))
(define sine-series
(cons-stream 0 (integrate-series cosine-series)))
;(display-stream sine-series)
問題 3.60
(load "streams.scm")
(define (mul-series s1 s2)
(cons-stream (* (stream-car s1) (stream-car s2))
(add-streams (stream-map
(lambda (x) (* (stream-car s1) x))
(stream-cdr s2))
(mul-series (stream-cdr s1) s2))))
(define (integrate-series coefs)
(let ((n 0))
(stream-map (lambda (x) (set! n (+ n 1)) (/ x n)) coefs)))
(define cosine-series
(cons-stream 1 (stream-map - (integrate-series sine-series))))
(define sine-series
(cons-stream 0 (integrate-series cosine-series)))
;; x は1でもよいのだから, 係数を出力してみる.
(display-stream
(add-streams
(mul-series sine-series sine-series)
(mul-series cosine-series cosine-series)))
問題 3.61
(load "streams.scm")
(define (mul-series s1 s2)
(cons-stream (* (stream-car s1) (stream-car s2))
(add-streams (stream-map
(lambda (x) (* (stream-car s1) x))
(stream-cdr s2))
(mul-series (stream-cdr s1) s2))))
(define (invert-unit-series sr)
(define x (cons-stream 1 (stream-map - (mul-series sr x))))
x)
(define (integrate-series coefs)
(let ((n 0))
(stream-map (lambda (x) (set! n (+ n 1)) (/ x n)) coefs)))
(define exp-series
(cons-stream 1 (integrate-series exp-series)))
(display-stream
(mul-series exp-series
(invert-unit-series (stream-cdr exp-series))))
→ ;; (exp x) * (1 / (exp *)) をやってみると,
1
0
0
0
0
問題 3.62
(load "streams.scm")
(define (mul-series s1 s2)
(cons-stream (* (stream-car s1) (stream-car s2))
(add-streams (stream-map
(lambda (x) (* (stream-car s1) x))
(stream-cdr s2))
(mul-series (stream-cdr s1) s2))))
(define (integrate-series coefs)
(let ((n 0))
(stream-map (lambda (x) (set! n (+ n 1)) (/ x n)) coefs)))
(define cosine-series
(cons-stream 1 (stream-map - (integrate-series sine-series))))
(define sine-series
(cons-stream 0 (integrate-series cosine-series)))
(define (invert-unit-series s)
(define x (cons-stream 1 (stream-map - (mul-series (stream-cdr s) x))))
x)
(define (div-series s1 s2)
(let ((constant-term (stream-car s2)))
(if (= constant-term 0) (error "divisor's constant term is zero" (stream-car s2))
(stream-map (lambda (x) (/ x constant-term))
(mul-series s1 (invert-unit-series
(stream-map (lambda (x) (/ x constant-term))
s2)))))))
(display-stream
(div-series sine-series cosine-series))
問題 3.64
(load "streams.scm")
(define (stream-limit stream tolerance)
(let ((first (stream-car stream)) (rest (stream-cdr stream)))
(if (< (abs (- first (stream-car rest))) tolerance)
first
(stream-limit rest tolerance))))
(define (sqrt-stream x)
(define guesses
(cons-stream 1.0
(stream-map (lambda (guess)
(sqrt-impreve guess x))
guesses)))
guesses)
(define (sqrt-impreve guess x)
(average guess (/ x guess)))
(define (average x y)
(/ (+ x y) 2))
(define (sqrt x tolerance)
(stream-limit (sqrt-stream x) tolerance))
(sqrt 2.0 0.001) → 1.4142156862745097
問題 3.65
(load "streams.scm")
(define (add-streams s1 s2) (stream-map + s1 s2))
(define (partial-sums s)
(define s1 (cons-stream (stream-car s) (add-streams (stream-cdr s) s1)))
s1)
(define (ln2-summands0 n)
(cons-stream (/ 1.0 n)
(ln2-summands1 (+ n 1)))))
(define (ln2-summands1 n)
(cons-stream (/ -1.0 n)
(ln2-summands0 (+ n 1)))))
(define ln2-stream
(partial-sums (ln2-summands0 1)))
(display-stream ln2-stream)
;;.5
;;.8333333333333333
;;.5833333333333333
;;.7833333333333332
;;.6166666666666666
;;.7595238095238095
;;.6345238095238095
;;.7456349206349207
;;.6456349206349207
;;.7365440115440116
;; ...
(define (square x) (* x x))
(define (euler-transform s)
(let ((s0 (stream-ref s 0))
(s1 (stream-ref s 1))
(s2 (stream-ref s 2)))
(cons-stream (- s2 (/ (square (- s2 s1))
(+ s0 (* -2 s1) s2)))
(euler-transform (stream-cdr s)))))
(display-stream (euler-transform ln2-stream))
;;.7
;;.6904761904761905
;;.6944444444444444
;;.6924242424242424
;;.6935897435897436
;;.6928571428571428
;;.6933473389355742
;;.6930033416875522
;;.6932539682539683
;;.6930657506744464
;; ...
(define (make-tableau transform s)
(cons-stream s
(make-tableau transform
(transform s))))
(define (accelerated-sequence transform s)
(stream-map stream-car
(make-tableau transform s)))
(display-stream (accelerated-sequence euler-transform
ln2-stream))
;;.7
;;.6932773109243697
;;.6931488693329254
;;.6931471960735491
;;.6931471806635636
;;.6931471805604039
;;.6931471805599445
;;.6931471805599427
;;.6931471805599454
問題 3.66
(load "streams.scm")
(define (add-streams s1 s2) (stream-map + s1 s2))
(define ones (cons-stream 1 ones))
(define integers (cons-stream 1 (add-streams ones integers)))
(define (interleave s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(interleave s2 (stream-cdr s1)))))
(define (pairs s t)
(cons-stream
(list (stream-car s) (stream-car t))
(interleave
(stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(pairs (stream-cdr s) (stream-cdr t)))))
;;(display-stream (pairs integers integers))
;;
;; 0 1 2 3 4 5 6 7 8 9
;;00 (1 1) (1 2) (2 2) (1 3) (2 3) (1 4) (3 3) (1 5) (2 4) (1 6)
;;10 (3 4) (1 7) (2 5) (1 8) (4 4) (1 9) (2 6) (1 10)(3 5) (1 11)
;;20 (2 7) (1 12)(4 5) (1 13)(2 8) (1 14)(3 6) (1 15)(2 9) (1 16)
;;30 (5 5) (1 17)(2 10)(1 18)(3 7) (1 19)(2 11)(1 20)(4 6) (1 21)
;;40 (2 12)(1 22)(3 8) (1 23)(2 13)(1 24)(5 6) (1 25)(2 14)(1 26)
;;50 (3 9) (1 27)(2 15)(1 28)(4 7) (1 29)(2 16)(1 30)(3 10)(1 31)
;;考え方
;; (1 1) の後 (1 2) (1 3) (1 4) ...と (2 2)以下のpairsをinterleaveするか
;; ら
;;
;; (1 1) (1 2) (1 3) (1 4)
;; (2 2) ...
;;
;;したがって(1 j)の位置は 0番, 1番, 3番, 5番, ...となる
;;(2 2)以下のpairsは
;;(2 2) (2 3) (2 4) (2 5)
;; (3 3) ...
;;
;;この順では(2 j)の位置は 0番, 1番, 3番, 5番, ...となるが,2番から始まっ
;;て(1 j)の列とinterleaveするから,k番は2k+2番になる. この調子でいくと,
;;(3 j)の列のk番は 2(2k+2)+k番になる.
;;
;;まず(i i)の位置を考える.
;;p(1 1)=0
;;p(2 2)=0+2=2
;;p(3 3)=2*2+2=2^2+2^1=6
;;p(4 4)=2*(2^2+2^1)+2=2^3+2^2+2^1=14
;;p(i i)=2^(i-1)+2^(i-2)+ ... 2^2+2^1=2^i-2
;;
;;さて(i j) (ただし(i < j))は(i i)から最初は2^(i-1)番後,それ以降は2^i番ずつ後に並
;;ぶから(j-i-1)*2^i+2^(i-1)を足せばよい.したがって
(define (place i j) ;; 対 i, j (i <= j)が何番目にくるか. (1 1)を0番とする
(let ((s (expt 2 (- i 1))))
(if (= i j)
(+ s s -2)
(+ s s -2 (* s (+ j j (- i) (- i) -1))))))
(place 1 100) → 197
(place 99 100) → 950737950171172051122527404030
(place 100 100) → 1267650600228229401496703205374
問題 3.67
(load "streams.scm")
(define (integers-starting-from n)
(cons-stream n (integers-starting-from (+ n 1))))
(define integers (integers-starting-from 1))
(define (interleave s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(interleave s2 (stream-cdr s1)))))
(define (pairs s t)
(cons-stream (list (stream-car s) (stream-car t))
(interleave
(interleave (stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(stream-map (lambda (x) (list x (stream-car t)))
(stream-cdr s)))
(pairs (stream-cdr s) (stream-cdr t)))))
(define (pairs s t)
(interleave
(stream-map (lambda (x) (list (stream-car s) x))
t)
(pairs (stream-cdr s) (stream-cdr t)))
)
(display-stream
(pairs integers integers))
問題 3.68
pairsの中のinterleaveがすぐpairsを呼ぶので, 呼出しのループに入り, 計算はすすまない.
問題 3.69
(define (display-stream s)
(stream-for-each display-line s))
(define (display-line x)
(newline)
(display x))
(define (stream-for-each proc s)
(if (stream-null? s)
'done
(begin (proc (stream-car s))
(stream-for-each proc (stream-cdr s)))))
(define ones (cons-stream 1 ones))
(define (add-streams s1 s2)
(stream-map + s1 s2))
(define integers (cons-stream 1 (add-streams ones integers)))
(define (stream-map proc . argstreams)
(if (stream-null? (car argstreams))
the-empty-stream
(cons-stream
(apply proc (map stream-car argstreams))
(apply stream-map
(cons proc (map stream-cdr argstreams))))))
(define (interleave s1 s2)
(if (stream-null? s1)
s2
(cons-stream (stream-car s1)
(interleave s2 (stream-cdr s1)))))
(define (pairs s t)
(cons-stream
(list (stream-car s) (stream-car t))
(interleave
(stream-map (lambda (x) (list (stream-car s) x))
(stream-cdr t))
(pairs (stream-cdr s) (stream-cdr t)))))
(define (triples s t u)
(cons-stream
(list (stream-car s) (stream-car t) (stream-car u))
(interleave
(stream-map (lambda (x) (cons (stream-car s) x))
(stream-cdr (pairs t u)))
(triples (stream-cdr s)
(stream-cdr t)
(stream-cdr u)))))
(define (pythagoras s)
(let ((triple (stream-car s)))
(let ((i (car triple)) (j (cadr triple)) (k (caddr triple)))
(cond ((= (+ (* i i) (* j j)) (* k k))
(display (list i j k)) (newline)))
(pythagoras (stream-cdr s)))))
(pythagoras (triples integers integers integers))
;;(3 4 5)
;;(6 8 10)
;;(5 12 13)
;;(9 12 15)
;;(8 15 17)
;;...
問題 3.70
(load "streams.scm")
(define (add-streams s1 s2) (stream-map + s1 s2))
(define ones (cons-stream 1 ones))
(define integers (cons-stream 1 (add-streams ones integers)))
(define (merge-weighted weight s1 s2)
(cond ((stream-null? s1) s2)
((stream-null? s2) s1)
(else
(let ((s1car (stream-car s1))
(s2car (stream-car s2)))
(if (< (apply weight s1car) (apply weight s2car))
(cons-stream s1car (merge-weighted weight (stream-cdr s1) s2))
(cons-stream s2car (merge-weighted weight s1 (stream-cdr s2))))))))
(define (weighted-pair weight s1 s2)
(cons-stream (list (stream-car s1) (stream-car s2))
(merge-weighted weight (stream-map (lambda (x) (list (stream-car s1) x))
(stream-cdr s2))
(weighted-pair weight (stream-cdr s1)
(stream-cdr s2)))))
;(display-stream
;(weighted-pair (lambda (x y) (+ x y)) integers integers))
(define str (stream-filter
(lambda (x) (and (> (remainder x 2) 0) (> (remainder x 3) 0)
(> (remainder x 5) 0))) integers))
(display-stream
(weighted-pair (lambda (i j) (+ (* 2 i) (* 3 j) (* 5 i j)))
str str))
;;(1 1)(1 7)(1 11)(1 13)(1 17)(1 19)(1 23)(1 29)(1 31)(7 7)
;;(1 37)(1 41)(1 43)(1 47)(1 49)(1 53)(7 11)(1 59)(1 61)(7 13)
;;(1 67)(1 71)(1 73)(1 77)(1 79)(11 11)(7 17)(1 83)(1 89)(1 91)
問題 3.71
(load "streams.scm")
(define (add-streams s1 s2) (stream-map + s1 s2))
(define ones (cons-stream 1 ones))
(define integers (cons-stream 1 (add-streams ones integers)))
(define (merge-weighted weight s1 s2)
(cond ((stream-null? s1) s2)
((stream-null? s2) s1)
(else
(let ((s1car (stream-car s1))
(s2car (stream-car s2)))
(if (< (apply weight s1car) (apply weight s2car))
(cons-stream s1car (merge-weighted weight (stream-cdr s1) s2))
(cons-stream s2car (merge-weighted weight s1 (stream-cdr s2))))))))
(define (weighted-pair weight s1 s2)
(cons-stream (list (stream-car s1) (stream-car s2))
(merge-weighted weight (stream-map (lambda (x) (list (stream-car s1) x))
(stream-cdr s2))
(weighted-pair weight (stream-cdr s1)
(stream-cdr s2)))))
(define (find-twin stream)
(let ((first (stream-car stream)) (rest (stream-cdr stream))
(second (stream-car (stream-cdr stream))))
(let ((i0 (car first)) (j0 (cadr first))
(i1 (car second)) (j1 (cadr second)))
(cond ((= (+ (* i0 i0 i0) (* j0 j0 j0)) (+ (* i1 i1 i1) (* j1 j1 j1)))
(display first) (display second) (newline)))
(find-twin rest))))
(find-twin
(weighted-pair (lambda (i j) (+ (* i i i) (* j j j))) integers integers))
;; (9 10)(1 12)
;; (9 15)(2 16)
;; (18 20)(2 24)
;; (19 24)(10 27)
;; (18 30)(4 32)
;; (15 33)(2 34)
;; (16 33)(9 34)
;; (27 30)(3 36)
;; (26 36)(17 39)
;; (31 33)(12 40)
問題 3.72
(load "streams.scm")
(define (add-streams s1 s2) (stream-map + s1 s2))
(define ones (cons-stream 1 ones))
(define integers (cons-stream 1 (add-streams ones integers)))
(define (merge-weighted weight s1 s2)
(cond ((stream-null? s1) s2)
((stream-null? s2) s1)
(else
(let ((s1car (stream-car s1))
(s2car (stream-car s2)))
(if (< (apply weight s1car) (apply weight s2car))
(cons-stream s1car (merge-weighted weight (stream-cdr s1) s2))
(cons-stream s2car (merge-weighted weight s1 (stream-cdr s2))))))))
(define (weighted-pair weight s1 s2)
(cons-stream (list (stream-car s1) (stream-car s2))
(merge-weighted weight (stream-map (lambda (x) (list (stream-car s1) x))
(stream-cdr s2))
(weighted-pair weight (stream-cdr s1)
(stream-cdr s2)))))
(define (find-triplet stream)
(let ((first (stream-car stream)) (rest (stream-cdr stream))
(second (stream-car (stream-cdr stream)))
(third (stream-car (stream-cdr (stream-cdr stream)))))
(let ((i0 (car first)) (j0 (cadr first))
(i1 (car second)) (j1 (cadr second))
(i2 (car third)) (j2 (cadr third)))
(cond ((and
(= (+ (* i0 i0) (* j0 j0)) (+ (* i1 i1) (* j1 j1)))
(= (+ (* i0 i0) (* j0 j0)) (+ (* i2 i2) (* j2 j2))))
(display first) (display second) (display third) (newline)))
(find-triplet rest))))
(find-triplet
(weighted-pair (lambda (i j) (+ (* i i) (* j j))) integers integers))
;;(10 15)(6 17)(1 18)
;;(13 16)(8 19)(5 20)
;;(17 19)(11 23)(5 25)
;;(14 23)(10 25)(7 26)
;;(19 22)(13 26)(2 29)
;;(15 25)(11 27)(3 29)
;;(21 22)(14 27)(5 30)
;;(20 25)(8 31)(1 32)
;;(23 24)(12 31)(9 32)
;;(12 31)(9 32)(4 33)
問題 3.73
(define (integral integrand initial-value dt)
(define int
(cons-stream initial-value
(add-streams (scale-stream integrand dt)
int)))
int)
(define (RC R C dt)
(lambda (i-stream vo)
(cons-stream v0
(add-streams (scale-stream i-stream R)
(integral (scale-stream i-stream (/ 1.0 C)) v0)))))
(define RC1 (RC 5 1 0.5))
問題 3.74
(define (list->stream list)
(if (null? list) the-empty-stream
(cons-stream (car list) (list->stream (cdr list)))))
(define sense-data
(list->stream
'(1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4)))
(define (sign-change-detector next last)
(cond ((and (>= next 0) (< last 0)) 1)
((and (< next 0) (>= last 0)) -1)
(else 0)))
(define (make-zero-crossings input-stream last-value)
(if (stream-null? input-stream)
the-empty-stream
(cons-stream
(sign-change-detector (stream-car input-stream) last-value)
(make-zero-crossings (stream-cdr input-stream)
(stream-car input-stream)))))
(define zero-crossings (make-zero-crossings sense-data 0))
(display-stream zero-crossings)
(newline)
(define (stream-map proc . argstreams)
(if (stream-null? (car argstreams))
the-empty-stream
(cons-stream
(apply proc (map stream-car argstreams))
(apply stream-map
(cons proc (map stream-cdr argstreams))))))
(define zero-crossings
(stream-map sign-change-detector sense-data
(cons-stream 0 sense-data)))
(display-stream zero-crossings)
→
0
0
0
0
0
-1
0
0
0
0
1
0
0
0
0
0
0
0
-1
0
0
0
0
1
0
0
問題 3.75
(define (list->stream list)
(if (null? list) the-empty-stream
(cons-stream (car list) (list->stream (cdr list)))))
(define sense-data
(list->stream
'(1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4)))
(define (sign-change-detector next last)
(cond ((and (>= next 0) (< last 0)) 1)
((and (< next 0) (>= last 0)) -1)
(else 0)))
(define (make-zero-crossings input-stream last-value last-avpt)
(if (stream-null? input-stream)
the-empty-stream
(let ((avpt (/ (+ (stream-car input-stream) last-value) 2))
(next-value (stream-car input-stream)))
(cons-stream (sign-change-detector avpt last-avpt)
(make-zero-crossings (stream-cdr input-stream)
next-value
avpt)))))
(define zero-crossings (make-zero-crossings sense-data 0 0))
(display-stream zero-crossings)
→
0
0
0
0
0
0
-1
0
0
0
0
1
0
問題 3.76
(define (list->stream list)
(if (null? list) the-empty-stream
(cons-stream (car list) (list->stream (cdr list)))))
(define sense-data
(list->stream
'(1 2 1.5 1 0.5 -0.1 -2 -3 -2 -0.5 0.2 3 4)))
(define (sign-change-detector next last)
(cond ((and (>= next 0) (< last 0)) 1)
((and (< next 0) (>= last 0)) -1)
(else 0)))
(define (smooth input-stream last-value)
(if (stream-null? input-stream) the-empty-stream
(let ((av (/ (+ (stream-car input-stream) last-value) 2)))
(cons-stream av
(smooth (stream-cdr input-stream) (stream-car input-stream))))))
(define (make-zero-crossings input-stream last-value)
(if (stream-null? input-stream)
the-empty-stream
(cons-stream (sign-change-detector (stream-car input-stream) last-value)
(make-zero-crossings (stream-cdr input-stream)
(stream-car input-stream)))))
(define zero-crossings (make-zero-crossings
(smooth sense-data 0) 0))
(display-stream zero-crossings)
→
0
0
0
0
0
0
-1
0
0
0
0
1
0
問題 3.77
(define (integral delayed-integrand initial-value dt)
(cons-stream initial-value
(let ((integrand (force delayed-integrand)))
(if (stream-null? integrand)
the-empty-stream
(integral (delay (stream-cdr integrand))
(+ (* dt (stream-car integrand))
initial-value)
dt)))))
(define (solve f y0 dt)
(define y (integral (delay dy) y0 dt))
(define dy (stream-map f y))
y)
(stream-ref (solve (lambda (y) y) 1 0.001) 1000) → 2.716923932235896
問題 3.78
(define (solve-2nd a b y0 dy0 dt)
(define y (integral (delay dy) y0 dt))
(define dy (integral (delay ddy) dy0 dt))
(define ddy (add-streams (scale-stream dy a) (scale-stream y b)))
y)
(display-stream (solve-2nd -2 -16 1 0 0.01))
この解は 速度に比例した抵抗を受ける質点の自由振動 を表す.
d2x/dt2+ 2h dx/dt+ k2 x=0 h,k≥0, h<k のとき
x=e-ht{c0 cos(√(k2 -h2 )t)+
c1 sin(√(k2 -h2 )t)}
が解.
下の図で青線が解, 黒線が積分値を示す.
問題 3.79
(load "streams.scm")
(define (integral delayed-integrand initial-value dt)
(cons-stream initial-value
(let ((integrand (force delayed-integrand)))
(if (stream-null? integrand)
the-empty-stream
(integral (delay (stream-cdr integrand))
(+ (* dt (stream-car integrand))
initial-value)
dt)))))
(define (solve-2nd f y0 dy0 dt)
(define y (integral (delay dy) y0 dt))
(define dy (integral (delay ddy) dy0 dt))
(define ddy (stream-map f dy y))
y)
(display-stream (solve-2nd (lambda (dy y) (+ (* -2 dy) (* -16 y))) 1 0 0.01))
問題 3.80
(load "streams.scm")
(define (integral delayed-integrand initial-value dt)
(cons-stream initial-value
(let ((integrand (force delayed-integrand)))
(if (stream-null? integrand)
the-empty-stream
(integral (delay (stream-cdr integrand))
(+ (* dt (stream-car integrand))
initial-value)
dt)))))
(define (RLC R L C dt)
(lambda (vC0 iL0)
(define vC (integral (delay dvC) vC0 dt))
(define iL (integral (delay diL) iL0 dt))
(define dvC (scale-stream iL (/ -1.0 C)))
(define diL (add-streams
(scale-stream vC (/ 1.0 L))
(scale-stream iL (/ (- R) L))))
(cons vC iL)))
(define (stream-for-each-pair proc s t)
(if (stream-null? s)
'done
(begin (proc (stream-car s) (stream-car t))
(stream-for-each-pair proc (stream-cdr s) (stream-cdr t)))))
(define (display-stream-pair stream)
(let ((s (car stream)) (t (cdr stream)))
(stream-for-each-pair display-pair-line s t)))
(define (display-pair-line x y)
(newline)
(display x) (display " ") (display y))
(display-stream-pair
((RLC 1 1 0.2 0.1) 10 0))
下の図で青線が電流 iL, 赤線が電圧 vCを示す.
問題 3.81
(define (list->stream list)
(if (null? list) the-empty-stream
(cons-stream (car list) (list->stream (cdr list)))))
(define (rand-update x)
(remainder (+ (* x 3125) 19683) 32768))
(define foo
'(generate generate generate generate reset 100
generate generate generate generate reset 100
generate generate generate generate))
(define bar
(list->stream foo))
(define (random s init)
(if (stream-null? s)
the-empty-stream
(cons-stream init
(cond ((eq? (stream-car s) 'generate)
(random (stream-cdr s) (rand-update init)))
((eq? (stream-car s) 'reset)
(random (stream-cdr (stream-cdr s)) (stream-car (stream-cdr s))))
(else 'error)))))
(display-stream (random bar 100))
問題 3.82
(define (estimate-integral P x1 x2 y1 y2)
(define (test passed failed)
(cons-stream (* (/ passed (+ passed failed)) 36.0)
(if (P (random-in-range x1 x2) (random-in-range y1 y2))
(test (+ passed 1) failed)
(test passed (+ failed 1)))))
(test 0 1))
(define (random-in-range low high)
(let ((range (- high low)))
(+ low (random range))))
(define (square x) (* x x))
(display-stream
(estimate-integral
(lambda (x y) (<= (+ (square (- x 5)) (square (- y 7))) 9))
2.0 8.0 4.0 10.0))