Blob


1 (define (memo-proc proc)
2 (let ((already-run? false) (result false))
3 (lambda ()
4 (if already-run?
5 result
6 (begin (set! already-run? true)
7 (set! result (proc))
8 result)))))
10 (define-syntax mydelay
11 (rsc-macro-transformer
12 (let ((xfmr
13 (lambda (exp)
14 `(memo-proc (lambda () ,exp)))))
15 (lambda (e r)
16 (apply xfmr (cdr e))))))
18 (define (myforce delayed-object)
19 (delayed-object))
21 (define-syntax cons-stream
22 (rsc-macro-transformer
23 (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
24 (lambda (e r)
25 (apply xfmr (cdr e))))))
27 (define (stream-car s)
28 (car s))
29 (define (stream-cdr s)
30 (myforce (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)
38 (if (= n 0)
39 (stream-car s)
40 (stream-ref (stream-cdr s) (- n 1))))
41 (define (stream-map proc . argstreams)
42 (if (stream-null? (car argstreams))
43 the-empty-stream
44 (cons-stream
45 (apply proc (map stream-car argstreams))
46 (apply stream-map (cons proc (map stream-cdr argstreams))))))
47 (define (stream-for-each proc s)
48 (if (stream-null? s)
49 'done
50 (begin (proc (stream-car s))
51 (stream-for-each proc (stream-cdr s)))))
53 (define (stream-enumerate-interval low high)
54 (if (> low high)
55 the-empty-stream
56 (cons-stream
57 low
58 (stream-enumerate-interval (+ low 1) high))))
59 (define (stream-filter pred s)
60 (if (stream-null? s)
61 the-empty-stream
62 (let ((scar (stream-car s)))
63 (if (pred scar)
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)
70 (newline)
71 (display x))
73 (define (test-case actual expected)
74 (newline)
75 (display "Actual: ")
76 (display actual)
77 (newline)
78 (display "Expected: ")
79 (display expected)
80 (newline))
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))
88 (define (fibgen a b)
89 (cons-stream a (fibgen b (+ a b))))
90 (define fibs (fibgen 0 1))
92 (define (sieve s)
93 (cons-stream
94 (stream-car s)
95 (sieve (stream-filter
96 (lambda (x)
97 (not (divisible? x (stream-car s))))
98 (stream-cdr 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)))
105 (define fibs
106 (cons-stream 0
107 (cons-stream 1
108 (add-streams (stream-cdr fibs)
109 fibs))))
111 (define (scale-stream stream factor)
112 (stream-map (lambda (x)
113 (* x factor))
114 stream))
116 (define primes
117 (cons-stream
119 (stream-filter prime? (integers-starting-from 3))))
120 (define (prime? n)
121 (define (iter ps)
122 (cond ((> (square (stream-car ps)) n) true)
123 ((divisible? n (stream-car ps)) false)
124 (else (iter (stream-cdr ps)))))
125 (iter primes))
127 (define (mul-streams s1 s2)
128 (stream-map * s1 s2))
130 (define (partial-sums s)
131 (define sums
132 (cons-stream (stream-car s)
133 (add-streams sums
134 (stream-cdr s))))
135 sums)
137 (define (merge s1 s2)
138 (cond ((stream-null? s1) s2)
139 ((stream-null? s2) s1)
140 (else
141 (let ((s1car (stream-car s1))
142 (s2car (stream-car s2)))
143 (cond ((< s1car s2car)
144 (cons-stream
145 s1car
146 (merge (stream-cdr s1) s2)))
147 ((> s1car s2car)
148 (cons-stream
149 s2car
150 (merge s1 (stream-cdr s2))))
151 (else
152 (cons-stream
153 s1car
154 (merge (stream-cdr s1) (stream-cdr s2)))))))))
156 (define (test-stream-list stream list)
157 (if (null? list)
158 'done
159 (begin (display "A: ")
160 (display (stream-car stream))
161 (display " -- ")
162 (display "E: ")
163 (display (car list))
164 (newline)
165 (test-stream-list (stream-cdr stream) (cdr list)))))
167 (define (integrate-series a)
168 (stream-map / a integers))
170 (define exp-series
171 (cons-stream 1 (integrate-series exp-series)))
173 (define cosine-series
174 (cons-stream
176 (integrate-series (stream-map - sine-series))))
177 (define sine-series
178 (cons-stream
180 (integrate-series cosine-series)))
182 (define (mul-series s1 s2)
183 (cons-stream
184 (* (stream-car s1) (stream-car s2))
185 (add-streams
186 (scale-stream (stream-cdr s2) (stream-car s1))
187 (mul-series (stream-cdr s1) s2))))
189 (define (invert-unit-series s)
190 (define x
191 (cons-stream
193 (mul-series (stream-map - (stream-cdr s))
194 x)))
195 x)
197 (define (div-series num den)
198 (let ((den-car (stream-car den)))
199 (if (zero? den-car)
200 (error "Denominator has zero constant term -- DIV-SERIES")
201 (scale-stream
202 (mul-series
203 num
204 (invert-unit-series (scale-stream den (/ 1 den-car))))
205 (/ 1 den-car)))))
208 (define (sqrt-improve guess x)
209 (define (average x y)
210 (/ (+ x y) 2))
211 (average guess (/ x guess)))
213 (define (sqrt-stream x)
214 (define guesses
215 (cons-stream
217 (stream-map (lambda (guess)
218 (sqrt-improve guess x))
219 guesses)))
220 guesses)
222 (define (pi-summands n)
223 (cons-stream (/ 1 n)
224 (stream-map - (pi-summands (+ n 2)))))
225 (define pi-stream
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)))
232 (cons-stream
233 (- s2 (/ (square (- s2 s1))
234 (+ s0 (* -2 s1) s2)))
235 (euler-transform (stream-cdr s)))))
237 (define (make-tableau transform s)
238 (cons-stream s
239 (make-tableau transform
240 (transform s))))
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)
247 scadr
248 (stream-limit scdr tol))))
250 (define (pairs s t)
251 (cons-stream
252 (list (stream-car s) (stream-car t))
253 (interleave
254 (stream-map
255 (lambda (x)
256 (list (stream-car s) x))
257 (stream-cdr t))
258 (pairs (stream-cdr s) (stream-cdr t)))))
259 (define (interleave s1 s2)
260 (if (stream-null? s1)
261 s2
262 (cons-stream (stream-car s1)
263 (interleave s2 (stream-cdr s1)))))
265 (define (display-streams n . streams)
266 (if (> n 0)
267 (begin (newline)
268 (for-each
269 (lambda (s)
270 (display (stream-car s))
271 (display " -- "))
272 streams)
273 (apply display-streams
274 (cons (- n 1) (map stream-cdr streams))))))
276 (define (all-pairs s t)
277 (cons-stream
278 (list (stream-car s) (stream-car t))
279 (interleave
280 (stream-map
281 (lambda (x)
282 (list x (stream-car t)))
283 (stream-cdr s))
284 (interleave
285 (stream-map
286 (lambda (x)
287 (list (stream-car s) x))
288 (stream-cdr t))
289 (all-pairs (stream-cdr s) (stream-cdr t))))))
291 (define (triples s t u)
292 (cons-stream
293 (list (stream-car s) (stream-car t) (stream-car u))
294 (interleave
295 (stream-cdr (stream-map (lambda (pair)
296 (cons (stream-car s) pair))
297 (pairs t u)))
298 (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
300 (define pythag-triples
301 (stream-filter
302 (lambda (triple)
303 (let ((i (car triple))
304 (j (cadr triple))
305 (k (caddr 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)
312 (else
313 (let ((s1car (stream-car s1))
314 (s2car (stream-car s2)))
315 (if (<= (weight s1car) (weight s2car))
316 (cons-stream
317 s1car
318 (merge-weighted (stream-cdr s1) s2 weight))
319 (cons-stream
320 s2car
321 (merge-weighted s1 (stream-cdr s2) weight)))))))
323 (define (weighted-pairs s t weight)
324 (cons-stream
325 (list (stream-car s) (stream-car t))
326 (merge-weighted
327 (stream-map
328 (lambda (x)
329 (list (stream-car s) x))
330 (stream-cdr t))
331 (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
332 weight)))
334 (define (integral integrand initial-value dt)
335 (define int
336 (cons-stream initial-value
337 (add-streams (scale-stream integrand dt)
338 int)))
339 int)
341 (define (list->stream list)
342 (if (null? list)
343 the-empty-stream
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))
350 y)
352 (define (integral delayed-integrand initial-value dt)
353 (define int
354 (cons-stream initial-value
355 (let ((integrand (myforce delayed-integrand)))
356 (add-streams (scale-stream integrand dt)
357 int))))
358 int)
360 ;; (define rand
361 ;; (let ((x random-init))
362 ;; (lambda ()
363 ;; (set! x (rand-update x))
364 ;; x)))
366 ;; (define (rand-update x)
367 ;; (let ((a (expt 2 32))
368 ;; (c 1103515245)
369 ;; (m 12345))
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)
381 (cons-stream
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))
387 random-numbers))
389 (define (monte-carlo experiment-stream passed failed)
390 (define (next passed failed)
391 (cons-stream
392 (/ passed (+ passed failed))
393 (monte-carlo
394 (stream-cdr experiment-stream) passed failed)))
395 (if (stream-car experiment-stream)
396 (next (+ passed 1) failed)
397 (next passed (+ failed 1))))
399 (define pi
400 (stream-map (lambda (p) (sqrt (/ 6 p)))
401 (monte-carlo cesaro-stream 0 0)))
402 (display-streams 10000 pi)