Blame


1 665c255d 2023-08-04 jrmu (define (memo-proc proc)
2 665c255d 2023-08-04 jrmu (let ((already-run? false) (result false))
3 665c255d 2023-08-04 jrmu (lambda ()
4 665c255d 2023-08-04 jrmu (if already-run?
5 665c255d 2023-08-04 jrmu result
6 665c255d 2023-08-04 jrmu (begin (set! already-run? true)
7 665c255d 2023-08-04 jrmu (set! result (proc))
8 665c255d 2023-08-04 jrmu result)))))
9 665c255d 2023-08-04 jrmu
10 665c255d 2023-08-04 jrmu (define-syntax mydelay
11 665c255d 2023-08-04 jrmu (rsc-macro-transformer
12 665c255d 2023-08-04 jrmu (let ((xfmr
13 665c255d 2023-08-04 jrmu (lambda (exp)
14 665c255d 2023-08-04 jrmu `(memo-proc (lambda () ,exp)))))
15 665c255d 2023-08-04 jrmu (lambda (e r)
16 665c255d 2023-08-04 jrmu (apply xfmr (cdr e))))))
17 665c255d 2023-08-04 jrmu
18 665c255d 2023-08-04 jrmu (define (myforce delayed-object)
19 665c255d 2023-08-04 jrmu (delayed-object))
20 665c255d 2023-08-04 jrmu
21 665c255d 2023-08-04 jrmu (define-syntax cons-stream
22 665c255d 2023-08-04 jrmu (rsc-macro-transformer
23 665c255d 2023-08-04 jrmu (let ((xfmr (lambda (x y) `(cons ,x (mydelay ,y)))))
24 665c255d 2023-08-04 jrmu (lambda (e r)
25 665c255d 2023-08-04 jrmu (apply xfmr (cdr e))))))
26 665c255d 2023-08-04 jrmu
27 665c255d 2023-08-04 jrmu (define (stream-car s)
28 665c255d 2023-08-04 jrmu (car s))
29 665c255d 2023-08-04 jrmu (define (stream-cdr s)
30 665c255d 2023-08-04 jrmu (myforce (cdr s)))
31 665c255d 2023-08-04 jrmu (define stream-null? null?)
32 665c255d 2023-08-04 jrmu (define the-empty-stream '())
33 665c255d 2023-08-04 jrmu
34 665c255d 2023-08-04 jrmu (define (integers-starting-from n)
35 665c255d 2023-08-04 jrmu (cons-stream n (integers-starting-from (+ n 1))))
36 665c255d 2023-08-04 jrmu
37 665c255d 2023-08-04 jrmu (define (stream-ref s n)
38 665c255d 2023-08-04 jrmu (if (= n 0)
39 665c255d 2023-08-04 jrmu (stream-car s)
40 665c255d 2023-08-04 jrmu (stream-ref (stream-cdr s) (- n 1))))
41 665c255d 2023-08-04 jrmu (define (stream-map proc . argstreams)
42 665c255d 2023-08-04 jrmu (if (stream-null? (car argstreams))
43 665c255d 2023-08-04 jrmu the-empty-stream
44 665c255d 2023-08-04 jrmu (cons-stream
45 665c255d 2023-08-04 jrmu (apply proc (map stream-car argstreams))
46 665c255d 2023-08-04 jrmu (apply stream-map (cons proc (map stream-cdr argstreams))))))
47 665c255d 2023-08-04 jrmu (define (stream-for-each proc s)
48 665c255d 2023-08-04 jrmu (if (stream-null? s)
49 665c255d 2023-08-04 jrmu 'done
50 665c255d 2023-08-04 jrmu (begin (proc (stream-car s))
51 665c255d 2023-08-04 jrmu (stream-for-each proc (stream-cdr s)))))
52 665c255d 2023-08-04 jrmu
53 665c255d 2023-08-04 jrmu (define (stream-enumerate-interval low high)
54 665c255d 2023-08-04 jrmu (if (> low high)
55 665c255d 2023-08-04 jrmu the-empty-stream
56 665c255d 2023-08-04 jrmu (cons-stream
57 665c255d 2023-08-04 jrmu low
58 665c255d 2023-08-04 jrmu (stream-enumerate-interval (+ low 1) high))))
59 665c255d 2023-08-04 jrmu (define (stream-filter pred s)
60 665c255d 2023-08-04 jrmu (if (stream-null? s)
61 665c255d 2023-08-04 jrmu the-empty-stream
62 665c255d 2023-08-04 jrmu (let ((scar (stream-car s)))
63 665c255d 2023-08-04 jrmu (if (pred scar)
64 665c255d 2023-08-04 jrmu (cons-stream scar (stream-filter pred (stream-cdr s)))
65 665c255d 2023-08-04 jrmu (stream-filter pred (stream-cdr s))))))
66 665c255d 2023-08-04 jrmu
67 665c255d 2023-08-04 jrmu (define (display-stream s)
68 665c255d 2023-08-04 jrmu (stream-for-each display-line s))
69 665c255d 2023-08-04 jrmu (define (display-line x)
70 665c255d 2023-08-04 jrmu (newline)
71 665c255d 2023-08-04 jrmu (display x))
72 665c255d 2023-08-04 jrmu
73 665c255d 2023-08-04 jrmu (define (test-case actual expected)
74 665c255d 2023-08-04 jrmu (newline)
75 665c255d 2023-08-04 jrmu (display "Actual: ")
76 665c255d 2023-08-04 jrmu (display actual)
77 665c255d 2023-08-04 jrmu (newline)
78 665c255d 2023-08-04 jrmu (display "Expected: ")
79 665c255d 2023-08-04 jrmu (display expected)
80 665c255d 2023-08-04 jrmu (newline))
81 665c255d 2023-08-04 jrmu
82 665c255d 2023-08-04 jrmu (define (integers-starting-from n)
83 665c255d 2023-08-04 jrmu (cons-stream n (integers-starting-from (+ n 1))))
84 665c255d 2023-08-04 jrmu (define integers (integers-starting-from 1))
85 665c255d 2023-08-04 jrmu
86 665c255d 2023-08-04 jrmu (define (divisible? x y) (= (remainder x y) 0))
87 665c255d 2023-08-04 jrmu
88 665c255d 2023-08-04 jrmu (define (fibgen a b)
89 665c255d 2023-08-04 jrmu (cons-stream a (fibgen b (+ a b))))
90 665c255d 2023-08-04 jrmu (define fibs (fibgen 0 1))
91 665c255d 2023-08-04 jrmu
92 665c255d 2023-08-04 jrmu (define (sieve s)
93 665c255d 2023-08-04 jrmu (cons-stream
94 665c255d 2023-08-04 jrmu (stream-car s)
95 665c255d 2023-08-04 jrmu (sieve (stream-filter
96 665c255d 2023-08-04 jrmu (lambda (x)
97 665c255d 2023-08-04 jrmu (not (divisible? x (stream-car s))))
98 665c255d 2023-08-04 jrmu (stream-cdr s)))))
99 665c255d 2023-08-04 jrmu
100 665c255d 2023-08-04 jrmu (define ones (cons-stream 1 ones))
101 665c255d 2023-08-04 jrmu (define (add-streams s1 s2)
102 665c255d 2023-08-04 jrmu (stream-map + s1 s2))
103 665c255d 2023-08-04 jrmu (define integers (cons-stream 1 (add-streams ones integers)))
104 665c255d 2023-08-04 jrmu
105 665c255d 2023-08-04 jrmu (define fibs
106 665c255d 2023-08-04 jrmu (cons-stream 0
107 665c255d 2023-08-04 jrmu (cons-stream 1
108 665c255d 2023-08-04 jrmu (add-streams (stream-cdr fibs)
109 665c255d 2023-08-04 jrmu fibs))))
110 665c255d 2023-08-04 jrmu
111 665c255d 2023-08-04 jrmu (define (scale-stream stream factor)
112 665c255d 2023-08-04 jrmu (stream-map (lambda (x)
113 665c255d 2023-08-04 jrmu (* x factor))
114 665c255d 2023-08-04 jrmu stream))
115 665c255d 2023-08-04 jrmu
116 665c255d 2023-08-04 jrmu (define primes
117 665c255d 2023-08-04 jrmu (cons-stream
118 665c255d 2023-08-04 jrmu 2
119 665c255d 2023-08-04 jrmu (stream-filter prime? (integers-starting-from 3))))
120 665c255d 2023-08-04 jrmu (define (prime? n)
121 665c255d 2023-08-04 jrmu (define (iter ps)
122 665c255d 2023-08-04 jrmu (cond ((> (square (stream-car ps)) n) true)
123 665c255d 2023-08-04 jrmu ((divisible? n (stream-car ps)) false)
124 665c255d 2023-08-04 jrmu (else (iter (stream-cdr ps)))))
125 665c255d 2023-08-04 jrmu (iter primes))
126 665c255d 2023-08-04 jrmu
127 665c255d 2023-08-04 jrmu (define (mul-streams s1 s2)
128 665c255d 2023-08-04 jrmu (stream-map * s1 s2))
129 665c255d 2023-08-04 jrmu
130 665c255d 2023-08-04 jrmu (define (partial-sums s)
131 665c255d 2023-08-04 jrmu (define sums
132 665c255d 2023-08-04 jrmu (cons-stream (stream-car s)
133 665c255d 2023-08-04 jrmu (add-streams sums
134 665c255d 2023-08-04 jrmu (stream-cdr s))))
135 665c255d 2023-08-04 jrmu sums)
136 665c255d 2023-08-04 jrmu
137 665c255d 2023-08-04 jrmu (define (merge s1 s2)
138 665c255d 2023-08-04 jrmu (cond ((stream-null? s1) s2)
139 665c255d 2023-08-04 jrmu ((stream-null? s2) s1)
140 665c255d 2023-08-04 jrmu (else
141 665c255d 2023-08-04 jrmu (let ((s1car (stream-car s1))
142 665c255d 2023-08-04 jrmu (s2car (stream-car s2)))
143 665c255d 2023-08-04 jrmu (cond ((< s1car s2car)
144 665c255d 2023-08-04 jrmu (cons-stream
145 665c255d 2023-08-04 jrmu s1car
146 665c255d 2023-08-04 jrmu (merge (stream-cdr s1) s2)))
147 665c255d 2023-08-04 jrmu ((> s1car s2car)
148 665c255d 2023-08-04 jrmu (cons-stream
149 665c255d 2023-08-04 jrmu s2car
150 665c255d 2023-08-04 jrmu (merge s1 (stream-cdr s2))))
151 665c255d 2023-08-04 jrmu (else
152 665c255d 2023-08-04 jrmu (cons-stream
153 665c255d 2023-08-04 jrmu s1car
154 665c255d 2023-08-04 jrmu (merge (stream-cdr s1) (stream-cdr s2)))))))))
155 665c255d 2023-08-04 jrmu
156 665c255d 2023-08-04 jrmu (define (test-stream-list stream list)
157 665c255d 2023-08-04 jrmu (if (null? list)
158 665c255d 2023-08-04 jrmu 'done
159 665c255d 2023-08-04 jrmu (begin (display "A: ")
160 665c255d 2023-08-04 jrmu (display (stream-car stream))
161 665c255d 2023-08-04 jrmu (display " -- ")
162 665c255d 2023-08-04 jrmu (display "E: ")
163 665c255d 2023-08-04 jrmu (display (car list))
164 665c255d 2023-08-04 jrmu (newline)
165 665c255d 2023-08-04 jrmu (test-stream-list (stream-cdr stream) (cdr list)))))
166 665c255d 2023-08-04 jrmu
167 665c255d 2023-08-04 jrmu (define (integrate-series a)
168 665c255d 2023-08-04 jrmu (stream-map / a integers))
169 665c255d 2023-08-04 jrmu
170 665c255d 2023-08-04 jrmu (define exp-series
171 665c255d 2023-08-04 jrmu (cons-stream 1 (integrate-series exp-series)))
172 665c255d 2023-08-04 jrmu
173 665c255d 2023-08-04 jrmu (define cosine-series
174 665c255d 2023-08-04 jrmu (cons-stream
175 665c255d 2023-08-04 jrmu 1
176 665c255d 2023-08-04 jrmu (integrate-series (stream-map - sine-series))))
177 665c255d 2023-08-04 jrmu (define sine-series
178 665c255d 2023-08-04 jrmu (cons-stream
179 665c255d 2023-08-04 jrmu 0
180 665c255d 2023-08-04 jrmu (integrate-series cosine-series)))
181 665c255d 2023-08-04 jrmu
182 665c255d 2023-08-04 jrmu (define (mul-series s1 s2)
183 665c255d 2023-08-04 jrmu (cons-stream
184 665c255d 2023-08-04 jrmu (* (stream-car s1) (stream-car s2))
185 665c255d 2023-08-04 jrmu (add-streams
186 665c255d 2023-08-04 jrmu (scale-stream (stream-cdr s2) (stream-car s1))
187 665c255d 2023-08-04 jrmu (mul-series (stream-cdr s1) s2))))
188 665c255d 2023-08-04 jrmu
189 665c255d 2023-08-04 jrmu (define (invert-unit-series s)
190 665c255d 2023-08-04 jrmu (define x
191 665c255d 2023-08-04 jrmu (cons-stream
192 665c255d 2023-08-04 jrmu 1
193 665c255d 2023-08-04 jrmu (mul-series (stream-map - (stream-cdr s))
194 665c255d 2023-08-04 jrmu x)))
195 665c255d 2023-08-04 jrmu x)
196 665c255d 2023-08-04 jrmu
197 665c255d 2023-08-04 jrmu (define (div-series num den)
198 665c255d 2023-08-04 jrmu (let ((den-car (stream-car den)))
199 665c255d 2023-08-04 jrmu (if (zero? den-car)
200 665c255d 2023-08-04 jrmu (error "Denominator has zero constant term -- DIV-SERIES")
201 665c255d 2023-08-04 jrmu (scale-stream
202 665c255d 2023-08-04 jrmu (mul-series
203 665c255d 2023-08-04 jrmu num
204 665c255d 2023-08-04 jrmu (invert-unit-series (scale-stream den (/ 1 den-car))))
205 665c255d 2023-08-04 jrmu (/ 1 den-car)))))
206 665c255d 2023-08-04 jrmu
207 665c255d 2023-08-04 jrmu
208 665c255d 2023-08-04 jrmu (define (sqrt-improve guess x)
209 665c255d 2023-08-04 jrmu (define (average x y)
210 665c255d 2023-08-04 jrmu (/ (+ x y) 2))
211 665c255d 2023-08-04 jrmu (average guess (/ x guess)))
212 665c255d 2023-08-04 jrmu
213 665c255d 2023-08-04 jrmu (define (sqrt-stream x)
214 665c255d 2023-08-04 jrmu (define guesses
215 665c255d 2023-08-04 jrmu (cons-stream
216 665c255d 2023-08-04 jrmu 1
217 665c255d 2023-08-04 jrmu (stream-map (lambda (guess)
218 665c255d 2023-08-04 jrmu (sqrt-improve guess x))
219 665c255d 2023-08-04 jrmu guesses)))
220 665c255d 2023-08-04 jrmu guesses)
221 665c255d 2023-08-04 jrmu
222 665c255d 2023-08-04 jrmu (define (pi-summands n)
223 665c255d 2023-08-04 jrmu (cons-stream (/ 1 n)
224 665c255d 2023-08-04 jrmu (stream-map - (pi-summands (+ n 2)))))
225 665c255d 2023-08-04 jrmu (define pi-stream
226 665c255d 2023-08-04 jrmu (scale-stream (partial-sums (pi-summands 1)) 4))
227 665c255d 2023-08-04 jrmu
228 665c255d 2023-08-04 jrmu (define (euler-transform s)
229 665c255d 2023-08-04 jrmu (let ((s0 (stream-ref s 0))
230 665c255d 2023-08-04 jrmu (s1 (stream-ref s 1))
231 665c255d 2023-08-04 jrmu (s2 (stream-ref s 2)))
232 665c255d 2023-08-04 jrmu (cons-stream
233 665c255d 2023-08-04 jrmu (- s2 (/ (square (- s2 s1))
234 665c255d 2023-08-04 jrmu (+ s0 (* -2 s1) s2)))
235 665c255d 2023-08-04 jrmu (euler-transform (stream-cdr s)))))
236 665c255d 2023-08-04 jrmu
237 665c255d 2023-08-04 jrmu (define (make-tableau transform s)
238 665c255d 2023-08-04 jrmu (cons-stream s
239 665c255d 2023-08-04 jrmu (make-tableau transform
240 665c255d 2023-08-04 jrmu (transform s))))
241 665c255d 2023-08-04 jrmu
242 665c255d 2023-08-04 jrmu (define (stream-limit s tol)
243 665c255d 2023-08-04 jrmu (let* ((scar (stream-car s))
244 665c255d 2023-08-04 jrmu (scdr (stream-cdr s))
245 665c255d 2023-08-04 jrmu (scadr (stream-car scdr)))
246 665c255d 2023-08-04 jrmu (if (< (abs (- scar scadr)) tol)
247 665c255d 2023-08-04 jrmu scadr
248 665c255d 2023-08-04 jrmu (stream-limit scdr tol))))
249 665c255d 2023-08-04 jrmu
250 665c255d 2023-08-04 jrmu (define (sqrt x tolerance)
251 665c255d 2023-08-04 jrmu (stream-limit (sqrt-stream x) tolerance))
252 665c255d 2023-08-04 jrmu
253 665c255d 2023-08-04 jrmu (define (pairs s t)
254 665c255d 2023-08-04 jrmu (cons-stream
255 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t))
256 665c255d 2023-08-04 jrmu (interleave
257 665c255d 2023-08-04 jrmu (stream-map
258 665c255d 2023-08-04 jrmu (lambda (x)
259 665c255d 2023-08-04 jrmu (list (stream-car s) x))
260 665c255d 2023-08-04 jrmu (stream-cdr t))
261 665c255d 2023-08-04 jrmu (pairs (stream-cdr s) (stream-cdr t)))))
262 665c255d 2023-08-04 jrmu (define (interleave s1 s2)
263 665c255d 2023-08-04 jrmu (if (stream-null? s1)
264 665c255d 2023-08-04 jrmu s2
265 665c255d 2023-08-04 jrmu (cons-stream (stream-car s1)
266 665c255d 2023-08-04 jrmu (interleave s2 (stream-cdr s1)))))
267 665c255d 2023-08-04 jrmu
268 665c255d 2023-08-04 jrmu (define (display-streams n . streams)
269 665c255d 2023-08-04 jrmu (if (> n 0)
270 665c255d 2023-08-04 jrmu (begin (newline)
271 665c255d 2023-08-04 jrmu (for-each
272 665c255d 2023-08-04 jrmu (lambda (s)
273 665c255d 2023-08-04 jrmu (display (stream-car s))
274 665c255d 2023-08-04 jrmu (display " -- "))
275 665c255d 2023-08-04 jrmu streams)
276 665c255d 2023-08-04 jrmu (apply display-streams
277 665c255d 2023-08-04 jrmu (cons (- n 1) (map stream-cdr streams))))))
278 665c255d 2023-08-04 jrmu
279 665c255d 2023-08-04 jrmu (define (all-pairs s t)
280 665c255d 2023-08-04 jrmu (cons-stream
281 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t))
282 665c255d 2023-08-04 jrmu (interleave
283 665c255d 2023-08-04 jrmu (stream-map
284 665c255d 2023-08-04 jrmu (lambda (x)
285 665c255d 2023-08-04 jrmu (list x (stream-car t)))
286 665c255d 2023-08-04 jrmu (stream-cdr s))
287 665c255d 2023-08-04 jrmu (interleave
288 665c255d 2023-08-04 jrmu (stream-map
289 665c255d 2023-08-04 jrmu (lambda (x)
290 665c255d 2023-08-04 jrmu (list (stream-car s) x))
291 665c255d 2023-08-04 jrmu (stream-cdr t))
292 665c255d 2023-08-04 jrmu (all-pairs (stream-cdr s) (stream-cdr t))))))
293 665c255d 2023-08-04 jrmu
294 665c255d 2023-08-04 jrmu (define (triples s t u)
295 665c255d 2023-08-04 jrmu (cons-stream
296 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t) (stream-car u))
297 665c255d 2023-08-04 jrmu (interleave
298 665c255d 2023-08-04 jrmu (stream-cdr (stream-map (lambda (pair)
299 665c255d 2023-08-04 jrmu (cons (stream-car s) pair))
300 665c255d 2023-08-04 jrmu (pairs t u)))
301 665c255d 2023-08-04 jrmu (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
302 665c255d 2023-08-04 jrmu
303 665c255d 2023-08-04 jrmu (define pythag-triples
304 665c255d 2023-08-04 jrmu (stream-filter
305 665c255d 2023-08-04 jrmu (lambda (triple)
306 665c255d 2023-08-04 jrmu (let ((i (car triple))
307 665c255d 2023-08-04 jrmu (j (cadr triple))
308 665c255d 2023-08-04 jrmu (k (caddr triple)))
309 665c255d 2023-08-04 jrmu (= (square k) (+ (square i) (square j)))))
310 665c255d 2023-08-04 jrmu (triples integers integers integers)))
311 665c255d 2023-08-04 jrmu
312 665c255d 2023-08-04 jrmu (define (merge-weighted s1 s2 weight)
313 665c255d 2023-08-04 jrmu (cond ((stream-null? s1) s2)
314 665c255d 2023-08-04 jrmu ((stream-null? s2) s1)
315 665c255d 2023-08-04 jrmu (else
316 665c255d 2023-08-04 jrmu (let ((s1car (stream-car s1))
317 665c255d 2023-08-04 jrmu (s2car (stream-car s2)))
318 665c255d 2023-08-04 jrmu (if (<= (weight s1car) (weight s2car))
319 665c255d 2023-08-04 jrmu (cons-stream
320 665c255d 2023-08-04 jrmu s1car
321 665c255d 2023-08-04 jrmu (merge-weighted (stream-cdr s1) s2 weight))
322 665c255d 2023-08-04 jrmu (cons-stream
323 665c255d 2023-08-04 jrmu s2car
324 665c255d 2023-08-04 jrmu (merge-weighted s1 (stream-cdr s2) weight)))))))
325 665c255d 2023-08-04 jrmu
326 665c255d 2023-08-04 jrmu (define (weighted-pairs s t weight)
327 665c255d 2023-08-04 jrmu (cons-stream
328 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t))
329 665c255d 2023-08-04 jrmu (merge-weighted
330 665c255d 2023-08-04 jrmu (stream-map
331 665c255d 2023-08-04 jrmu (lambda (x)
332 665c255d 2023-08-04 jrmu (list (stream-car s) x))
333 665c255d 2023-08-04 jrmu (stream-cdr t))
334 665c255d 2023-08-04 jrmu (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
335 665c255d 2023-08-04 jrmu weight)))
336 665c255d 2023-08-04 jrmu
337 665c255d 2023-08-04 jrmu (define (integral integrand initial-value dt)
338 665c255d 2023-08-04 jrmu (define int
339 665c255d 2023-08-04 jrmu (cons-stream initial-value
340 665c255d 2023-08-04 jrmu (add-streams (scale-stream integrand dt)
341 665c255d 2023-08-04 jrmu int)))
342 665c255d 2023-08-04 jrmu int)
343 665c255d 2023-08-04 jrmu
344 665c255d 2023-08-04 jrmu (define (list->stream list)
345 665c255d 2023-08-04 jrmu (if (null? list)
346 665c255d 2023-08-04 jrmu the-empty-stream
347 665c255d 2023-08-04 jrmu (cons-stream (car list)
348 665c255d 2023-08-04 jrmu (list->stream (cdr list)))))
349 665c255d 2023-08-04 jrmu
350 665c255d 2023-08-04 jrmu
351 665c255d 2023-08-04 jrmu (define int
352 665c255d 2023-08-04 jrmu (cons-stream initial-value
353 665c255d 2023-08-04 jrmu (add-streas (scale-stream integrand dt)
354 665c255d 2023-08-04 jrmu int)))