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))
88 (stream-filter (lambda (x) (not (divisible? x 7)))
92 (cons-stream a (fibgen b (+ a b))))
93 (define fibs (fibgen 0 1))
100 (not (divisible? x (stream-car s))))
103 ;; (define primes (sieve (integers-starting-from 2)))
104 ;; (test-case (stream-ref primes 25) 101)
106 (define ones (cons-stream 1 ones))
107 (define (add-streams s1 s2)
108 (stream-map + s1 s2))
109 (define integers (cons-stream 1 (add-streams ones integers)))
110 ;; (test-case (stream-ref integers 15) 16)
115 (add-streams (stream-cdr fibs)
118 (define (scale-stream stream factor)
119 (stream-map (lambda (x)
122 (define double (cons-stream 1 (scale-stream double 2)))
127 (stream-filter prime? (integers-starting-from 3))))
130 (cond ((> (square (stream-car ps)) n) true)
131 ((divisible? n (stream-car ps)) false)
132 (else (iter (stream-cdr ps)))))
135 (define (mul-streams s1 s2)
136 (stream-map * s1 s2))
138 (define (partial-sums s)
140 (cons-stream (stream-car s)
145 (define (merge s1 s2)
146 (cond ((stream-null? s1) s2)
147 ((stream-null? s2) s1)
149 (let ((s1car (stream-car s1))
150 (s2car (stream-car s2)))
151 (cond ((< s1car s2car)
154 (merge (stream-cdr s1) s2)))
158 (merge s1 (stream-cdr s2))))
162 (merge (stream-cdr s1) (stream-cdr s2)))))))))
164 (define (test-stream-list stream list)
167 (begin (display "A: ")
168 (display (stream-car stream))
173 (test-stream-list (stream-cdr stream) (cdr list)))))
175 (define (integrate-series a)
176 (stream-map / a integers))
179 (cons-stream 1 (integrate-series exp-series)))
181 (define cosine-series
184 (integrate-series (stream-map - sine-series))))
188 (integrate-series cosine-series)))
190 (define (mul-series s1 s2)
192 (* (stream-car s1) (stream-car s2))
194 (scale-stream (stream-cdr s2) (stream-car s1))
195 (mul-series (stream-cdr s1) s2))))
197 (define (invert-unit-series s)
201 (mul-series (stream-map - (stream-cdr s))
205 (define (div-series num den)
206 (let ((den-car (stream-car den)))
208 (error "Denominator has zero constant term -- DIV-SERIES")
212 (invert-unit-series (scale-stream den (/ 1 den-car))))
216 (define (sqrt-improve guess x)
217 (define (average x y)
219 (average guess (/ x guess)))
221 (define (sqrt-stream x)
225 (stream-map (lambda (guess)
226 (sqrt-improve guess x))
230 (define (pi-summands n)
232 (stream-map - (pi-summands (+ n 2)))))
234 (scale-stream (partial-sums (pi-summands 1)) 4))
236 (define (euler-transform s)
237 (let ((s0 (stream-ref s 0))
238 (s1 (stream-ref s 1))
239 (s2 (stream-ref s 2)))
241 (- s2 (/ (square (- s2 s1))
242 (+ s0 (* -2 s1) s2)))
243 (euler-transform (stream-cdr s)))))
245 (define (make-tableau transform s)
247 (make-tableau transform
250 (define (stream-limit s tol)
251 (let* ((scar (stream-car s))
252 (scdr (stream-cdr s))
253 (scadr (stream-car scdr)))
254 (if (< (abs (- scar scadr)) tol)
256 (stream-limit scdr tol))))
258 (define (sqrt x tolerance)
259 (stream-limit (sqrt-stream x) tolerance))
263 (list (stream-car s) (stream-car t))
267 (list (stream-car s) x))
269 (pairs (stream-cdr s) (stream-cdr t)))))
270 (define (interleave s1 s2)
271 (if (stream-null? s1)
273 (cons-stream (stream-car s1)
274 (interleave s2 (stream-cdr s1)))))
276 (define (display-streams n . streams)
281 (display (stream-car s))
284 (apply display-streams
285 (cons (- n 1) (map stream-cdr streams))))))
287 (define (all-pairs s t)
289 (list (stream-car s) (stream-car t))
293 (list x (stream-car t)))
298 (list (stream-car s) x))
300 (all-pairs (stream-cdr s) (stream-cdr t))))))
302 (define (triples s t u)
304 (list (stream-car s) (stream-car t) (stream-car u))
306 (stream-cdr (stream-map (lambda (pair)
307 (cons (stream-car s) pair))
309 (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
311 (define pythag-triples
314 (let ((i (car triple))
317 (= (square k) (+ (square i) (square j)))))
318 (triples integers integers integers)))
320 (define (merge-weighted s1 s2 weight)
321 (cond ((stream-null? s1) s2)
322 ((stream-null? s2) s1)
324 (let ((s1car (stream-car s1))
325 (s2car (stream-car s2)))
326 (if (<= (weight s1car) (weight s2car))
329 (merge-weighted (stream-cdr s1) s2 weight))
332 (merge-weighted s1 (stream-cdr s2) weight)))))))
334 (define (weighted-pairs s t weight)
336 (list (stream-car s) (stream-car t))
340 (list (stream-car s) x))
342 (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
345 ;; 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?
354 (define i3+j3-pairs (weighted-pairs integers integers i3+j3))
356 (define (two-same-weight s weight)
357 (let* ((scar (stream-car s))
358 (scdr (stream-cdr s))
359 (scadr (stream-car scdr)))
360 (if (= (weight scar) (weight scadr))
361 (cons-stream (list scar scadr (weight scar))
362 (two-same-weight scdr weight))
363 (two-same-weight scdr weight))))
365 ;; (define ramanujan (two-same-weight i3+j3-pairs i3+j3))
366 ;; (test-stream-list ramanujan '(1729 4104 13832 20683 32832 39312))
368 ;; Exercise 3.72. In a similar way to exercise 3.71 generate a stream of all numbers that can be written as the sum of two squares in three different ways (showing how they can be so written).
376 (define i2+j2-pairs (weighted-pairs integers integers i2+j2))
377 (define (three-same-weight s weight)
378 (let* ((scar (stream-car s))
379 (scdr (stream-cdr s))
380 (scadr (stream-car scdr))
381 (scddr (stream-cdr scdr))
382 (scaddr (stream-car scddr)))
383 (if (= (weight scar) (weight scadr) (weight scaddr))
384 (cons-stream (list scar scadr scaddr (weight scar))
385 (three-same-weight scdr weight))
386 (three-same-weight scdr weight))))
387 (define three-ways (three-same-weight i2+j2-pairs i2+j2))
388 (display-streams 10 three-ways)
