1 665c255d 2023-08-04 jrmu (define (memo-proc proc)
2 665c255d 2023-08-04 jrmu (let ((already-run? false) (result false))
4 665c255d 2023-08-04 jrmu (if already-run?
6 665c255d 2023-08-04 jrmu (begin (set! already-run? true)
7 665c255d 2023-08-04 jrmu (set! result (proc))
10 665c255d 2023-08-04 jrmu (define-syntax mydelay
11 665c255d 2023-08-04 jrmu (rsc-macro-transformer
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))))))
18 665c255d 2023-08-04 jrmu (define (myforce delayed-object)
19 665c255d 2023-08-04 jrmu (delayed-object))
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))))))
27 665c255d 2023-08-04 jrmu (define (stream-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 '())
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))))
37 665c255d 2023-08-04 jrmu (define (stream-ref s n)
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)
50 665c255d 2023-08-04 jrmu (begin (proc (stream-car s))
51 665c255d 2023-08-04 jrmu (stream-for-each proc (stream-cdr s)))))
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
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))))))
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)
71 665c255d 2023-08-04 jrmu (display x))
73 665c255d 2023-08-04 jrmu (define (test-case actual expected)
75 665c255d 2023-08-04 jrmu (display "Actual: ")
76 665c255d 2023-08-04 jrmu (display actual)
78 665c255d 2023-08-04 jrmu (display "Expected: ")
79 665c255d 2023-08-04 jrmu (display expected)
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))
86 665c255d 2023-08-04 jrmu (define (divisible? x y) (= (remainder x y) 0))
87 665c255d 2023-08-04 jrmu (define no-sevens
88 665c255d 2023-08-04 jrmu (stream-filter (lambda (x) (not (divisible? x 7)))
91 665c255d 2023-08-04 jrmu (define (fibgen a b)
92 665c255d 2023-08-04 jrmu (cons-stream a (fibgen b (+ a b))))
93 665c255d 2023-08-04 jrmu (define fibs (fibgen 0 1))
95 665c255d 2023-08-04 jrmu (define (sieve s)
96 665c255d 2023-08-04 jrmu (cons-stream
97 665c255d 2023-08-04 jrmu (stream-car s)
98 665c255d 2023-08-04 jrmu (sieve (stream-filter
100 665c255d 2023-08-04 jrmu (not (divisible? x (stream-car s))))
101 665c255d 2023-08-04 jrmu (stream-cdr s)))))
103 665c255d 2023-08-04 jrmu ;; (define primes (sieve (integers-starting-from 2)))
104 665c255d 2023-08-04 jrmu ;; (test-case (stream-ref primes 25) 101)
106 665c255d 2023-08-04 jrmu (define ones (cons-stream 1 ones))
107 665c255d 2023-08-04 jrmu (define (add-streams s1 s2)
108 665c255d 2023-08-04 jrmu (stream-map + s1 s2))
109 665c255d 2023-08-04 jrmu (define integers (cons-stream 1 (add-streams ones integers)))
110 665c255d 2023-08-04 jrmu ;; (test-case (stream-ref integers 15) 16)
112 665c255d 2023-08-04 jrmu (define fibs
113 665c255d 2023-08-04 jrmu (cons-stream 0
114 665c255d 2023-08-04 jrmu (cons-stream 1
115 665c255d 2023-08-04 jrmu (add-streams (stream-cdr fibs)
118 665c255d 2023-08-04 jrmu (define (scale-stream stream factor)
119 665c255d 2023-08-04 jrmu (stream-map (lambda (x)
120 665c255d 2023-08-04 jrmu (* x factor))
122 665c255d 2023-08-04 jrmu (define double (cons-stream 1 (scale-stream double 2)))
124 665c255d 2023-08-04 jrmu (define primes
125 665c255d 2023-08-04 jrmu (cons-stream
127 665c255d 2023-08-04 jrmu (stream-filter prime? (integers-starting-from 3))))
128 665c255d 2023-08-04 jrmu (define (prime? n)
129 665c255d 2023-08-04 jrmu (define (iter ps)
130 665c255d 2023-08-04 jrmu (cond ((> (square (stream-car ps)) n) true)
131 665c255d 2023-08-04 jrmu ((divisible? n (stream-car ps)) false)
132 665c255d 2023-08-04 jrmu (else (iter (stream-cdr ps)))))
133 665c255d 2023-08-04 jrmu (iter primes))
135 665c255d 2023-08-04 jrmu (define (mul-streams s1 s2)
136 665c255d 2023-08-04 jrmu (stream-map * s1 s2))
138 665c255d 2023-08-04 jrmu (define (partial-sums s)
139 665c255d 2023-08-04 jrmu (define sums
140 665c255d 2023-08-04 jrmu (cons-stream (stream-car s)
141 665c255d 2023-08-04 jrmu (add-streams sums
142 665c255d 2023-08-04 jrmu (stream-cdr s))))
145 665c255d 2023-08-04 jrmu (define (merge s1 s2)
146 665c255d 2023-08-04 jrmu (cond ((stream-null? s1) s2)
147 665c255d 2023-08-04 jrmu ((stream-null? s2) s1)
149 665c255d 2023-08-04 jrmu (let ((s1car (stream-car s1))
150 665c255d 2023-08-04 jrmu (s2car (stream-car s2)))
151 665c255d 2023-08-04 jrmu (cond ((< s1car s2car)
152 665c255d 2023-08-04 jrmu (cons-stream
154 665c255d 2023-08-04 jrmu (merge (stream-cdr s1) s2)))
155 665c255d 2023-08-04 jrmu ((> s1car s2car)
156 665c255d 2023-08-04 jrmu (cons-stream
158 665c255d 2023-08-04 jrmu (merge s1 (stream-cdr s2))))
160 665c255d 2023-08-04 jrmu (cons-stream
162 665c255d 2023-08-04 jrmu (merge (stream-cdr s1) (stream-cdr s2)))))))))
164 665c255d 2023-08-04 jrmu (define (test-stream-list stream list)
165 665c255d 2023-08-04 jrmu (if (null? list)
167 665c255d 2023-08-04 jrmu (begin (display "A: ")
168 665c255d 2023-08-04 jrmu (display (stream-car stream))
169 665c255d 2023-08-04 jrmu (display " -- ")
170 665c255d 2023-08-04 jrmu (display "E: ")
171 665c255d 2023-08-04 jrmu (display (car list))
173 665c255d 2023-08-04 jrmu (test-stream-list (stream-cdr stream) (cdr list)))))
175 665c255d 2023-08-04 jrmu (define (integrate-series a)
176 665c255d 2023-08-04 jrmu (stream-map / a integers))
178 665c255d 2023-08-04 jrmu (define exp-series
179 665c255d 2023-08-04 jrmu (cons-stream 1 (integrate-series exp-series)))
181 665c255d 2023-08-04 jrmu (define cosine-series
182 665c255d 2023-08-04 jrmu (cons-stream
184 665c255d 2023-08-04 jrmu (integrate-series (stream-map - sine-series))))
185 665c255d 2023-08-04 jrmu (define sine-series
186 665c255d 2023-08-04 jrmu (cons-stream
188 665c255d 2023-08-04 jrmu (integrate-series cosine-series)))
190 665c255d 2023-08-04 jrmu (define (mul-series s1 s2)
191 665c255d 2023-08-04 jrmu (cons-stream
192 665c255d 2023-08-04 jrmu (* (stream-car s1) (stream-car s2))
193 665c255d 2023-08-04 jrmu (add-streams
194 665c255d 2023-08-04 jrmu (scale-stream (stream-cdr s2) (stream-car s1))
195 665c255d 2023-08-04 jrmu (mul-series (stream-cdr s1) s2))))
197 665c255d 2023-08-04 jrmu (define (invert-unit-series s)
199 665c255d 2023-08-04 jrmu (cons-stream
201 665c255d 2023-08-04 jrmu (mul-series (stream-map - (stream-cdr s))
205 665c255d 2023-08-04 jrmu (define (div-series num den)
206 665c255d 2023-08-04 jrmu (let ((den-car (stream-car den)))
207 665c255d 2023-08-04 jrmu (if (zero? den-car)
208 665c255d 2023-08-04 jrmu (error "Denominator has zero constant term -- DIV-SERIES")
209 665c255d 2023-08-04 jrmu (scale-stream
210 665c255d 2023-08-04 jrmu (mul-series
212 665c255d 2023-08-04 jrmu (invert-unit-series (scale-stream den (/ 1 den-car))))
213 665c255d 2023-08-04 jrmu (/ 1 den-car)))))
216 665c255d 2023-08-04 jrmu (define (sqrt-improve guess x)
217 665c255d 2023-08-04 jrmu (define (average x y)
218 665c255d 2023-08-04 jrmu (/ (+ x y) 2))
219 665c255d 2023-08-04 jrmu (average guess (/ x guess)))
221 665c255d 2023-08-04 jrmu (define (sqrt-stream x)
222 665c255d 2023-08-04 jrmu (define guesses
223 665c255d 2023-08-04 jrmu (cons-stream
225 665c255d 2023-08-04 jrmu (stream-map (lambda (guess)
226 665c255d 2023-08-04 jrmu (sqrt-improve guess x))
230 665c255d 2023-08-04 jrmu (define (pi-summands n)
231 665c255d 2023-08-04 jrmu (cons-stream (/ 1 n)
232 665c255d 2023-08-04 jrmu (stream-map - (pi-summands (+ n 2)))))
233 665c255d 2023-08-04 jrmu (define pi-stream
234 665c255d 2023-08-04 jrmu (scale-stream (partial-sums (pi-summands 1)) 4))
236 665c255d 2023-08-04 jrmu (define (euler-transform s)
237 665c255d 2023-08-04 jrmu (let ((s0 (stream-ref s 0))
238 665c255d 2023-08-04 jrmu (s1 (stream-ref s 1))
239 665c255d 2023-08-04 jrmu (s2 (stream-ref s 2)))
240 665c255d 2023-08-04 jrmu (cons-stream
241 665c255d 2023-08-04 jrmu (- s2 (/ (square (- s2 s1))
242 665c255d 2023-08-04 jrmu (+ s0 (* -2 s1) s2)))
243 665c255d 2023-08-04 jrmu (euler-transform (stream-cdr s)))))
245 665c255d 2023-08-04 jrmu (define (make-tableau transform s)
246 665c255d 2023-08-04 jrmu (cons-stream s
247 665c255d 2023-08-04 jrmu (make-tableau transform
248 665c255d 2023-08-04 jrmu (transform s))))
250 665c255d 2023-08-04 jrmu (define (stream-limit s tol)
251 665c255d 2023-08-04 jrmu (let* ((scar (stream-car s))
252 665c255d 2023-08-04 jrmu (scdr (stream-cdr s))
253 665c255d 2023-08-04 jrmu (scadr (stream-car scdr)))
254 665c255d 2023-08-04 jrmu (if (< (abs (- scar scadr)) tol)
256 665c255d 2023-08-04 jrmu (stream-limit scdr tol))))
258 665c255d 2023-08-04 jrmu (define (sqrt x tolerance)
259 665c255d 2023-08-04 jrmu (stream-limit (sqrt-stream x) tolerance))
261 665c255d 2023-08-04 jrmu (define (pairs s t)
262 665c255d 2023-08-04 jrmu (cons-stream
263 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t))
264 665c255d 2023-08-04 jrmu (interleave
265 665c255d 2023-08-04 jrmu (stream-map
266 665c255d 2023-08-04 jrmu (lambda (x)
267 665c255d 2023-08-04 jrmu (list (stream-car s) x))
268 665c255d 2023-08-04 jrmu (stream-cdr t))
269 665c255d 2023-08-04 jrmu (pairs (stream-cdr s) (stream-cdr t)))))
270 665c255d 2023-08-04 jrmu (define (interleave s1 s2)
271 665c255d 2023-08-04 jrmu (if (stream-null? s1)
273 665c255d 2023-08-04 jrmu (cons-stream (stream-car s1)
274 665c255d 2023-08-04 jrmu (interleave s2 (stream-cdr s1)))))
276 665c255d 2023-08-04 jrmu (define (display-streams n . streams)
277 665c255d 2023-08-04 jrmu (if (> n 0)
278 665c255d 2023-08-04 jrmu (begin (newline)
280 665c255d 2023-08-04 jrmu (lambda (s)
281 665c255d 2023-08-04 jrmu (display (stream-car s))
282 665c255d 2023-08-04 jrmu (display " -- "))
284 665c255d 2023-08-04 jrmu (apply display-streams
285 665c255d 2023-08-04 jrmu (cons (- n 1) (map stream-cdr streams))))))
287 665c255d 2023-08-04 jrmu (define (all-pairs s t)
288 665c255d 2023-08-04 jrmu (cons-stream
289 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t))
290 665c255d 2023-08-04 jrmu (interleave
291 665c255d 2023-08-04 jrmu (stream-map
292 665c255d 2023-08-04 jrmu (lambda (x)
293 665c255d 2023-08-04 jrmu (list x (stream-car t)))
294 665c255d 2023-08-04 jrmu (stream-cdr s))
295 665c255d 2023-08-04 jrmu (interleave
296 665c255d 2023-08-04 jrmu (stream-map
297 665c255d 2023-08-04 jrmu (lambda (x)
298 665c255d 2023-08-04 jrmu (list (stream-car s) x))
299 665c255d 2023-08-04 jrmu (stream-cdr t))
300 665c255d 2023-08-04 jrmu (all-pairs (stream-cdr s) (stream-cdr t))))))
302 665c255d 2023-08-04 jrmu (define (triples s t u)
303 665c255d 2023-08-04 jrmu (cons-stream
304 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t) (stream-car u))
305 665c255d 2023-08-04 jrmu (interleave
306 665c255d 2023-08-04 jrmu (stream-cdr (stream-map (lambda (pair)
307 665c255d 2023-08-04 jrmu (cons (stream-car s) pair))
308 665c255d 2023-08-04 jrmu (pairs t u)))
309 665c255d 2023-08-04 jrmu (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
311 665c255d 2023-08-04 jrmu (define pythag-triples
312 665c255d 2023-08-04 jrmu (stream-filter
313 665c255d 2023-08-04 jrmu (lambda (triple)
314 665c255d 2023-08-04 jrmu (let ((i (car triple))
315 665c255d 2023-08-04 jrmu (j (cadr triple))
316 665c255d 2023-08-04 jrmu (k (caddr triple)))
317 665c255d 2023-08-04 jrmu (= (square k) (+ (square i) (square j)))))
318 665c255d 2023-08-04 jrmu (triples integers integers integers)))
320 665c255d 2023-08-04 jrmu ;; Exercise 3.70. It would be nice to be able to generate streams in which the pairs appear in some useful order, rather than in the order that results from an ad hoc interleaving process. We can use a technique similar to the merge procedure of exercise 3.56, if we define a way to say that one pair of integers is ``less than'' another. One way to do this is to define a ``weighting function'' W(i,j) and stipulate that (i1,j1) is less than (i2,j2) if W(i1,j1) < W(i2,j2). Write a procedure merge-weighted that is like merge, except that merge-weighted takes an additional argument weight, which is a procedure that computes the weight of a pair, and is used to determine the order in which elements should appear in the resulting merged stream.69 Using this, generalize pairs to a procedure weighted-pairs that takes two streams, together with a procedure that computes a weighting function, and generates the stream of pairs, ordered according to weight. Use your procedure to generate
322 665c255d 2023-08-04 jrmu (define (merge-weighted s1 s2 weight)
323 665c255d 2023-08-04 jrmu (cond ((stream-null? s1) s2)
324 665c255d 2023-08-04 jrmu ((stream-null? s2) s1)
326 665c255d 2023-08-04 jrmu (let ((s1car (stream-car s1))
327 665c255d 2023-08-04 jrmu (s2car (stream-car s2)))
328 665c255d 2023-08-04 jrmu (if (<= (weight s1car) (weight s2car))
329 665c255d 2023-08-04 jrmu (cons-stream
331 665c255d 2023-08-04 jrmu (merge-weighted (stream-cdr s1) s2 weight))
332 665c255d 2023-08-04 jrmu (cons-stream
334 665c255d 2023-08-04 jrmu (merge-weighted s1 (stream-cdr s2) weight)))))))
336 665c255d 2023-08-04 jrmu (define (weighted-pairs s t weight)
337 665c255d 2023-08-04 jrmu (cons-stream
338 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t))
339 665c255d 2023-08-04 jrmu (merge-weighted
340 665c255d 2023-08-04 jrmu (stream-map
341 665c255d 2023-08-04 jrmu (lambda (x)
342 665c255d 2023-08-04 jrmu (list (stream-car s) x))
343 665c255d 2023-08-04 jrmu (stream-cdr t))
344 665c255d 2023-08-04 jrmu (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
347 665c255d 2023-08-04 jrmu ;; a. the stream of all pairs of positive integers (i,j) with i < j ordered according to the sum i + j
350 665c255d 2023-08-04 jrmu ;; (1 2) (1 3) (1 4) (1 5) (1 6)
352 665c255d 2023-08-04 jrmu ;; (2 3) (2 4) (2 5) (2 6) (2 7)
353 665c255d 2023-08-04 jrmu ;; (3 3) ...
355 665c255d 2023-08-04 jrmu (define i<j (weighted-pairs integers integers (lambda (pair) (apply + pair))))
356 665c255d 2023-08-04 jrmu (test-stream-list i<j '((1 1) (1 2) (1 3) (2 2) (1 4) (2 3) (1 5) (2 4) (3 3) (1 6) (2 5) (3 4)))
358 665c255d 2023-08-04 jrmu ;; b. the stream of all pairs of positive integers (i,j) with i < j, where neither i nor j is divisible by 2, 3, or 5, and the pairs are ordered according to the sum 2 i + 3 j + 5 i j.
360 665c255d 2023-08-04 jrmu (define no235 (stream-filter (lambda (x)
361 665c255d 2023-08-04 jrmu (not (or (divisible? x 2)
362 665c255d 2023-08-04 jrmu (divisible? x 3)
363 665c255d 2023-08-04 jrmu (divisible? x 5))))
366 665c255d 2023-08-04 jrmu (define no235-pairs
367 665c255d 2023-08-04 jrmu (weighted-pairs
370 665c255d 2023-08-04 jrmu (lambda (pair)
371 665c255d 2023-08-04 jrmu (let ((i (car pair))
372 665c255d 2023-08-04 jrmu (j (cadr pair)))
375 665c255d 2023-08-04 jrmu (* 5 i j))))))
377 665c255d 2023-08-04 jrmu (display-streams 20 no235 no235-pairs)