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 (define (merge-weighted s1 s2 weight)
321 665c255d 2023-08-04 jrmu (cond ((stream-null? s1) s2)
322 665c255d 2023-08-04 jrmu ((stream-null? s2) s1)
324 665c255d 2023-08-04 jrmu (let ((s1car (stream-car s1))
325 665c255d 2023-08-04 jrmu (s2car (stream-car s2)))
326 665c255d 2023-08-04 jrmu (if (<= (weight s1car) (weight s2car))
327 665c255d 2023-08-04 jrmu (cons-stream
329 665c255d 2023-08-04 jrmu (merge-weighted (stream-cdr s1) s2 weight))
330 665c255d 2023-08-04 jrmu (cons-stream
332 665c255d 2023-08-04 jrmu (merge-weighted s1 (stream-cdr s2) weight)))))))
334 665c255d 2023-08-04 jrmu (define (weighted-pairs s t weight)
335 665c255d 2023-08-04 jrmu (cons-stream
336 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t))
337 665c255d 2023-08-04 jrmu (merge-weighted
338 665c255d 2023-08-04 jrmu (stream-map
339 665c255d 2023-08-04 jrmu (lambda (x)
340 665c255d 2023-08-04 jrmu (list (stream-car s) x))
341 665c255d 2023-08-04 jrmu (stream-cdr t))
342 665c255d 2023-08-04 jrmu (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
345 665c255d 2023-08-04 jrmu ;; Exercise 3.71. Numbers that can be expressed as the sum of two cubes in more than one way are sometimes called Ramanujan numbers, in honor of the mathematician Srinivasa Ramanujan.70 Ordered streams of pairs provide an elegant solution to the problem of computing these numbers. To find a number that can be written as the sum of two cubes in two different ways, we need only generate the stream of pairs of integers (i,j) weighted according to the sum i3 + j3 (see exercise 3.70), then search the stream for two consecutive pairs with the same weight. Write a procedure to generate the Ramanujan numbers. The first such number is 1,729. What are the next five?
347 665c255d 2023-08-04 jrmu (define (i3+j3 pair)
348 665c255d 2023-08-04 jrmu (let ((i (car pair))
349 665c255d 2023-08-04 jrmu (j (cadr pair)))
350 665c255d 2023-08-04 jrmu (+ (* i i i)
351 665c255d 2023-08-04 jrmu (* j j j))))
354 665c255d 2023-08-04 jrmu (define i3+j3-pairs (weighted-pairs integers integers i3+j3))
356 665c255d 2023-08-04 jrmu (define (two-same-weight s weight)
357 665c255d 2023-08-04 jrmu (let* ((scar (stream-car s))
358 665c255d 2023-08-04 jrmu (scdr (stream-cdr s))
359 665c255d 2023-08-04 jrmu (scadr (stream-car scdr)))
360 665c255d 2023-08-04 jrmu (if (= (weight scar) (weight scadr))
361 665c255d 2023-08-04 jrmu (cons-stream (list scar scadr (weight scar))
362 665c255d 2023-08-04 jrmu (two-same-weight scdr weight))
363 665c255d 2023-08-04 jrmu (two-same-weight scdr weight))))
365 665c255d 2023-08-04 jrmu (define ramanujan (two-same-weight i3+j3-pairs i3+j3))
366 665c255d 2023-08-04 jrmu (test-stream-list ramanujan '(1729 4104 13832 20683 32832 39312))