1 (define (memo-proc proc)
2 (let ((already-run? false) (result false))
6 (begin (set! already-run? true)
10 (define-syntax mydelay
11 (rsc-macro-transformer
14 `(memo-proc (lambda () ,exp)))))
16 (apply xfmr (cdr e))))))
18 (define (myforce delayed-object)
21 (define-syntax cons-stream
22 (rsc-macro-transformer
23 (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
25 (apply xfmr (cdr e))))))
27 (define (stream-car s)
29 (define (stream-cdr s)
31 (define stream-null? null?)
32 (define the-empty-stream '())
34 (define (integers-starting-from n)
35 (cons-stream n (integers-starting-from (+ n 1))))
37 (define (stream-ref s n)
40 (stream-ref (stream-cdr s) (- n 1))))
41 (define (stream-map proc . argstreams)
42 (if (stream-null? (car argstreams))
45 (apply proc (map stream-car argstreams))
46 (apply stream-map (cons proc (map stream-cdr argstreams))))))
47 (define (stream-for-each proc s)
50 (begin (proc (stream-car s))
51 (stream-for-each proc (stream-cdr s)))))
53 (define (stream-enumerate-interval low high)
58 (stream-enumerate-interval (+ low 1) high))))
59 (define (stream-filter pred s)
62 (let ((scar (stream-car s)))
64 (cons-stream scar (stream-filter pred (stream-cdr s)))
65 (stream-filter pred (stream-cdr s))))))
67 (define (display-stream s)
68 (stream-for-each display-line s))
69 (define (display-line x)
73 (define (test-case actual expected)
78 (display "Expected: ")
82 (define (integers-starting-from n)
83 (cons-stream n (integers-starting-from (+ n 1))))
84 (define integers (integers-starting-from 1))
86 (define (divisible? x y) (= (remainder x y) 0))
89 (cons-stream a (fibgen b (+ a b))))
90 (define fibs (fibgen 0 1))
97 (not (divisible? x (stream-car s))))
100 (define ones (cons-stream 1 ones))
101 (define (add-streams s1 s2)
102 (stream-map + s1 s2))
103 (define integers (cons-stream 1 (add-streams ones integers)))
108 (add-streams (stream-cdr fibs)
111 (define (scale-stream stream factor)
112 (stream-map (lambda (x)
119 (stream-filter prime? (integers-starting-from 3))))
122 (cond ((> (square (stream-car ps)) n) true)
123 ((divisible? n (stream-car ps)) false)
124 (else (iter (stream-cdr ps)))))
127 (define (mul-streams s1 s2)
128 (stream-map * s1 s2))
130 (define (partial-sums s)
132 (cons-stream (stream-car s)
137 (define (merge s1 s2)
138 (cond ((stream-null? s1) s2)
139 ((stream-null? s2) s1)
141 (let ((s1car (stream-car s1))
142 (s2car (stream-car s2)))
143 (cond ((< s1car s2car)
146 (merge (stream-cdr s1) s2)))
150 (merge s1 (stream-cdr s2))))
154 (merge (stream-cdr s1) (stream-cdr s2)))))))))
156 (define (test-stream-list stream list)
159 (begin (display "A: ")
160 (display (stream-car stream))
165 (test-stream-list (stream-cdr stream) (cdr list)))))
167 (define (integrate-series a)
168 (stream-map / a integers))
171 (cons-stream 1 (integrate-series exp-series)))
173 (define cosine-series
176 (integrate-series (stream-map - sine-series))))
180 (integrate-series cosine-series)))
182 (define (mul-series s1 s2)
184 (* (stream-car s1) (stream-car s2))
186 (scale-stream (stream-cdr s2) (stream-car s1))
187 (mul-series (stream-cdr s1) s2))))
189 (define (invert-unit-series s)
193 (mul-series (stream-map - (stream-cdr s))
197 (define (div-series num den)
198 (let ((den-car (stream-car den)))
200 (error "Denominator has zero constant term -- DIV-SERIES")
204 (invert-unit-series (scale-stream den (/ 1 den-car))))
208 (define (sqrt-improve guess x)
209 (define (average x y)
211 (average guess (/ x guess)))
213 (define (sqrt-stream x)
217 (stream-map (lambda (guess)
218 (sqrt-improve guess x))
222 (define (pi-summands n)
224 (stream-map - (pi-summands (+ n 2)))))
226 (scale-stream (partial-sums (pi-summands 1)) 4))
228 (define (euler-transform s)
229 (let ((s0 (stream-ref s 0))
230 (s1 (stream-ref s 1))
231 (s2 (stream-ref s 2)))
233 (- s2 (/ (square (- s2 s1))
234 (+ s0 (* -2 s1) s2)))
235 (euler-transform (stream-cdr s)))))
237 (define (make-tableau transform s)
239 (make-tableau transform
242 (define (stream-limit s tol)
243 (let* ((scar (stream-car s))
244 (scdr (stream-cdr s))
245 (scadr (stream-car scdr)))
246 (if (< (abs (- scar scadr)) tol)
248 (stream-limit scdr tol))))
252 (list (stream-car s) (stream-car t))
256 (list (stream-car s) x))
258 (pairs (stream-cdr s) (stream-cdr t)))))
259 (define (interleave s1 s2)
260 (if (stream-null? s1)
262 (cons-stream (stream-car s1)
263 (interleave s2 (stream-cdr s1)))))
265 (define (display-streams n . streams)
270 (display (stream-car s))
273 (apply display-streams
274 (cons (- n 1) (map stream-cdr streams))))))
276 (define (all-pairs s t)
278 (list (stream-car s) (stream-car t))
282 (list x (stream-car t)))
287 (list (stream-car s) x))
289 (all-pairs (stream-cdr s) (stream-cdr t))))))
291 (define (triples s t u)
293 (list (stream-car s) (stream-car t) (stream-car u))
295 (stream-cdr (stream-map (lambda (pair)
296 (cons (stream-car s) pair))
298 (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
300 (define pythag-triples
303 (let ((i (car triple))
306 (= (square k) (+ (square i) (square j)))))
307 (triples integers integers integers)))
309 (define (merge-weighted s1 s2 weight)
310 (cond ((stream-null? s1) s2)
311 ((stream-null? s2) s1)
313 (let ((s1car (stream-car s1))
314 (s2car (stream-car s2)))
315 (if (<= (weight s1car) (weight s2car))
318 (merge-weighted (stream-cdr s1) s2 weight))
321 (merge-weighted s1 (stream-cdr s2) weight)))))))
323 (define (weighted-pairs s t weight)
325 (list (stream-car s) (stream-car t))
329 (list (stream-car s) x))
331 (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
334 (define (integral integrand initial-value dt)
336 (cons-stream initial-value
337 (add-streams (scale-stream integrand dt)
341 (define (list->stream list)
344 (cons-stream (car list)
345 (list->stream (cdr list)))))
347 (define (solve f y0 dt)
348 (define y (integral (mydelay dy) y0 dt))
349 (define dy (stream-map f y))
352 (define (integral delayed-integrand initial-value dt)
354 (cons-stream initial-value
355 (let ((integrand (myforce delayed-integrand)))
356 (add-streams (scale-stream integrand dt)
361 ;; (let ((x random-init))
363 ;; (set! x (rand-update x))
366 ;; (define (rand-update x)
367 ;; (let ((a (expt 2 32))
370 ;; (modulo (+ (* a x) c) m)))
371 ;; (define random-init 137)
373 (define random-init 317)
374 (define (rand-update x)
375 (random (expt 2 31)))
377 (define random-numbers
378 (cons-stream random-init
379 (stream-map rand-update random-numbers)))
380 (define (map-successive-pairs f s)
382 (f (stream-car s) (stream-car (stream-cdr s)))
383 (map-successive-pairs f (stream-cdr (stream-cdr s)))))
385 (define cesaro-stream
386 (map-successive-pairs (lambda (r1 r2) (= (gcd r1 r2) 1))
389 (define (monte-carlo experiment-stream passed failed)
390 (define (next passed failed)
392 (/ passed (+ passed failed))
394 (stream-cdr experiment-stream) passed failed)))
395 (if (stream-car experiment-stream)
396 (next (+ passed 1) failed)
397 (next passed (+ failed 1))))
400 (stream-map (lambda (p) (sqrt (/ 6 p)))
401 (monte-carlo cesaro-stream 0 0)))
402 (display-streams 10000 pi)