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 ;; 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 (define (merge-weighted s1 s2 weight)
323 (cond ((stream-null? s1) s2)
324 ((stream-null? s2) s1)
326 (let ((s1car (stream-car s1))
327 (s2car (stream-car s2)))
328 (if (<= (weight s1car) (weight s2car))
331 (merge-weighted (stream-cdr s1) s2 weight))
334 (merge-weighted s1 (stream-cdr s2) weight)))))))
336 (define (weighted-pairs s t weight)
338 (list (stream-car s) (stream-car t))
342 (list (stream-car s) x))
344 (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
347 ;; a. the stream of all pairs of positive integers (i,j) with i < j ordered according to the sum i + j
350 ;; (1 2) (1 3) (1 4) (1 5) (1 6)
352 ;; (2 3) (2 4) (2 5) (2 6) (2 7)
355 (define i<j (weighted-pairs integers integers (lambda (pair) (apply + pair))))
356 (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 ;; 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 (define no235 (stream-filter (lambda (x)
361 (not (or (divisible? x 2)
377 (display-streams 20 no235 no235-pairs)
