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 (pairs s t)
251 665c255d 2023-08-04 jrmu (cons-stream
252 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t))
253 665c255d 2023-08-04 jrmu (interleave
254 665c255d 2023-08-04 jrmu (stream-map
255 665c255d 2023-08-04 jrmu (lambda (x)
256 665c255d 2023-08-04 jrmu (list (stream-car s) x))
257 665c255d 2023-08-04 jrmu (stream-cdr t))
258 665c255d 2023-08-04 jrmu (pairs (stream-cdr s) (stream-cdr t)))))
259 665c255d 2023-08-04 jrmu (define (interleave s1 s2)
260 665c255d 2023-08-04 jrmu (if (stream-null? s1)
261 665c255d 2023-08-04 jrmu s2
262 665c255d 2023-08-04 jrmu (cons-stream (stream-car s1)
263 665c255d 2023-08-04 jrmu (interleave s2 (stream-cdr s1)))))
264 665c255d 2023-08-04 jrmu
265 665c255d 2023-08-04 jrmu (define (display-streams n . streams)
266 665c255d 2023-08-04 jrmu (if (> n 0)
267 665c255d 2023-08-04 jrmu (begin (newline)
268 665c255d 2023-08-04 jrmu (for-each
269 665c255d 2023-08-04 jrmu (lambda (s)
270 665c255d 2023-08-04 jrmu (display (stream-car s))
271 665c255d 2023-08-04 jrmu (display " -- "))
272 665c255d 2023-08-04 jrmu streams)
273 665c255d 2023-08-04 jrmu (apply display-streams
274 665c255d 2023-08-04 jrmu (cons (- n 1) (map stream-cdr streams))))))
275 665c255d 2023-08-04 jrmu
276 665c255d 2023-08-04 jrmu (define (all-pairs s t)
277 665c255d 2023-08-04 jrmu (cons-stream
278 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t))
279 665c255d 2023-08-04 jrmu (interleave
280 665c255d 2023-08-04 jrmu (stream-map
281 665c255d 2023-08-04 jrmu (lambda (x)
282 665c255d 2023-08-04 jrmu (list x (stream-car t)))
283 665c255d 2023-08-04 jrmu (stream-cdr s))
284 665c255d 2023-08-04 jrmu (interleave
285 665c255d 2023-08-04 jrmu (stream-map
286 665c255d 2023-08-04 jrmu (lambda (x)
287 665c255d 2023-08-04 jrmu (list (stream-car s) x))
288 665c255d 2023-08-04 jrmu (stream-cdr t))
289 665c255d 2023-08-04 jrmu (all-pairs (stream-cdr s) (stream-cdr t))))))
290 665c255d 2023-08-04 jrmu
291 665c255d 2023-08-04 jrmu (define (triples s t u)
292 665c255d 2023-08-04 jrmu (cons-stream
293 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t) (stream-car u))
294 665c255d 2023-08-04 jrmu (interleave
295 665c255d 2023-08-04 jrmu (stream-cdr (stream-map (lambda (pair)
296 665c255d 2023-08-04 jrmu (cons (stream-car s) pair))
297 665c255d 2023-08-04 jrmu (pairs t u)))
298 665c255d 2023-08-04 jrmu (triples (stream-cdr s) (stream-cdr t) (stream-cdr u)))))
299 665c255d 2023-08-04 jrmu
300 665c255d 2023-08-04 jrmu (define pythag-triples
301 665c255d 2023-08-04 jrmu (stream-filter
302 665c255d 2023-08-04 jrmu (lambda (triple)
303 665c255d 2023-08-04 jrmu (let ((i (car triple))
304 665c255d 2023-08-04 jrmu (j (cadr triple))
305 665c255d 2023-08-04 jrmu (k (caddr triple)))
306 665c255d 2023-08-04 jrmu (= (square k) (+ (square i) (square j)))))
307 665c255d 2023-08-04 jrmu (triples integers integers integers)))
308 665c255d 2023-08-04 jrmu
309 665c255d 2023-08-04 jrmu (define (merge-weighted s1 s2 weight)
310 665c255d 2023-08-04 jrmu (cond ((stream-null? s1) s2)
311 665c255d 2023-08-04 jrmu ((stream-null? s2) s1)
312 665c255d 2023-08-04 jrmu (else
313 665c255d 2023-08-04 jrmu (let ((s1car (stream-car s1))
314 665c255d 2023-08-04 jrmu (s2car (stream-car s2)))
315 665c255d 2023-08-04 jrmu (if (<= (weight s1car) (weight s2car))
316 665c255d 2023-08-04 jrmu (cons-stream
317 665c255d 2023-08-04 jrmu s1car
318 665c255d 2023-08-04 jrmu (merge-weighted (stream-cdr s1) s2 weight))
319 665c255d 2023-08-04 jrmu (cons-stream
320 665c255d 2023-08-04 jrmu s2car
321 665c255d 2023-08-04 jrmu (merge-weighted s1 (stream-cdr s2) weight)))))))
322 665c255d 2023-08-04 jrmu
323 665c255d 2023-08-04 jrmu (define (weighted-pairs s t weight)
324 665c255d 2023-08-04 jrmu (cons-stream
325 665c255d 2023-08-04 jrmu (list (stream-car s) (stream-car t))
326 665c255d 2023-08-04 jrmu (merge-weighted
327 665c255d 2023-08-04 jrmu (stream-map
328 665c255d 2023-08-04 jrmu (lambda (x)
329 665c255d 2023-08-04 jrmu (list (stream-car s) x))
330 665c255d 2023-08-04 jrmu (stream-cdr t))
331 665c255d 2023-08-04 jrmu (weighted-pairs (stream-cdr s) (stream-cdr t) weight)
332 665c255d 2023-08-04 jrmu weight)))
333 665c255d 2023-08-04 jrmu
334 665c255d 2023-08-04 jrmu (define (integral integrand initial-value dt)
335 665c255d 2023-08-04 jrmu (define int
336 665c255d 2023-08-04 jrmu (cons-stream initial-value
337 665c255d 2023-08-04 jrmu (add-streams (scale-stream integrand dt)
338 665c255d 2023-08-04 jrmu int)))
339 665c255d 2023-08-04 jrmu int)
340 665c255d 2023-08-04 jrmu
341 665c255d 2023-08-04 jrmu (define (list->stream list)
342 665c255d 2023-08-04 jrmu (if (null? list)
343 665c255d 2023-08-04 jrmu the-empty-stream
344 665c255d 2023-08-04 jrmu (cons-stream (car list)
345 665c255d 2023-08-04 jrmu (list->stream (cdr list)))))
346 665c255d 2023-08-04 jrmu
347 665c255d 2023-08-04 jrmu (define (solve f y0 dt)
348 665c255d 2023-08-04 jrmu (define y (integral (mydelay dy) y0 dt))
349 665c255d 2023-08-04 jrmu (define dy (stream-map f y))
350 665c255d 2023-08-04 jrmu y)
351 665c255d 2023-08-04 jrmu
352 665c255d 2023-08-04 jrmu (define (integral delayed-integrand initial-value dt)
353 665c255d 2023-08-04 jrmu (define int
354 665c255d 2023-08-04 jrmu (cons-stream initial-value
355 665c255d 2023-08-04 jrmu (let ((integrand (myforce delayed-integrand)))
356 665c255d 2023-08-04 jrmu (add-streams (scale-stream integrand dt)
357 665c255d 2023-08-04 jrmu int))))
358 665c255d 2023-08-04 jrmu int)
359 665c255d 2023-08-04 jrmu
360 665c255d 2023-08-04 jrmu ;; (define rand
361 665c255d 2023-08-04 jrmu ;; (let ((x random-init))
362 665c255d 2023-08-04 jrmu ;; (lambda ()
363 665c255d 2023-08-04 jrmu ;; (set! x (rand-update x))
364 665c255d 2023-08-04 jrmu ;; x)))
365 665c255d 2023-08-04 jrmu
366 665c255d 2023-08-04 jrmu ;; (define (rand-update x)
367 665c255d 2023-08-04 jrmu ;; (let ((a (expt 2 32))
368 665c255d 2023-08-04 jrmu ;; (c 1103515245)
369 665c255d 2023-08-04 jrmu ;; (m 12345))
370 665c255d 2023-08-04 jrmu ;; (modulo (+ (* a x) c) m)))
371 665c255d 2023-08-04 jrmu ;; (define random-init 137)
372 665c255d 2023-08-04 jrmu
373 665c255d 2023-08-04 jrmu
374 665c255d 2023-08-04 jrmu ;; (define random-numbers
375 665c255d 2023-08-04 jrmu ;; (cons-stream random-init
376 665c255d 2023-08-04 jrmu ;; (stream-map rand-update random-numbers)))
377 665c255d 2023-08-04 jrmu
378 665c255d 2023-08-04 jrmu ;; (define (map-successive-pairs f s)
379 665c255d 2023-08-04 jrmu ;; (cons-stream
380 665c255d 2023-08-04 jrmu ;; (f (stream-car s) (stream-car (stream-cdr s)))
381 665c255d 2023-08-04 jrmu ;; (map-successive-pairs f (stream-cdr (stream-cdr s)))))
382 665c255d 2023-08-04 jrmu
383 665c255d 2023-08-04 jrmu ;; (define cesaro-stream
384 665c255d 2023-08-04 jrmu ;; (map-successive-pairs (lambda (r1 r2)
385 665c255d 2023-08-04 jrmu ;; (= (gcd r1 r2) 1))
386 665c255d 2023-08-04 jrmu ;; random-numbers))
387 665c255d 2023-08-04 jrmu
388 665c255d 2023-08-04 jrmu ;; (define (monte-carlo experiment-stream pass fail)
389 665c255d 2023-08-04 jrmu ;; (define (next pass fail)
390 665c255d 2023-08-04 jrmu ;; (cons-stream
391 665c255d 2023-08-04 jrmu ;; (/ pass (+ pass fail))
392 665c255d 2023-08-04 jrmu ;; (monte-carlo
393 665c255d 2023-08-04 jrmu ;; (stream-cdr experiment-stream) pass fail)))
394 665c255d 2023-08-04 jrmu ;; (if (stream-car experiment-stream)
395 665c255d 2023-08-04 jrmu ;; (next (+ pass 1) fail)
396 665c255d 2023-08-04 jrmu ;; (next pass (+ fail 1))))
397 665c255d 2023-08-04 jrmu
398 665c255d 2023-08-04 jrmu ;; (define pi (stream-map (lambda (p) (sqrt (/ 6.0 p)))
399 665c255d 2023-08-04 jrmu ;; (monte-carlo cesaro-stream 0 0)))
400 665c255d 2023-08-04 jrmu ;; (display-streams 100 pi)
401 665c255d 2023-08-04 jrmu
402 665c255d 2023-08-04 jrmu ;; Exercise 3.81. Exercise 3.6 discussed generalizing the random-number generator to allow one to reset the random-number sequence so as to produce repeatable sequences of ``random'' numbers. Produce a stream formulation of this same generator that operates on an input stream of requests to generate a new random number or to reset the sequence to a specified value and that produces the desired stream of random numbers. Don't use assignment in your solution.
403 665c255d 2023-08-04 jrmu
404 665c255d 2023-08-04 jrmu ;;(define (rand-update x)
405 665c255d 2023-08-04 jrmu ;; (randomize x)
406 665c255d 2023-08-04 jrmu ;; (random (expt 2 31)))
407 665c255d 2023-08-04 jrmu (define (rand-update x)
408 665c255d 2023-08-04 jrmu (let ((a (expt 2 32))
409 665c255d 2023-08-04 jrmu (c 1103515245)
410 665c255d 2023-08-04 jrmu (m 12345))
411 665c255d 2023-08-04 jrmu (modulo (+ (* a x) c) m)))
412 665c255d 2023-08-04 jrmu (define initial-seed 12392)
413 665c255d 2023-08-04 jrmu (rand-update initial-seed)
414 665c255d 2023-08-04 jrmu
415 665c255d 2023-08-04 jrmu
416 665c255d 2023-08-04 jrmu (define (random-number-generator commands)
417 665c255d 2023-08-04 jrmu (define (choose seed command)
418 665c255d 2023-08-04 jrmu (if (and (pair? command) (eq? (car command) 'reset))
419 665c255d 2023-08-04 jrmu (rand-update (cadr command))
420 665c255d 2023-08-04 jrmu (rand-update seed)))
421 665c255d 2023-08-04 jrmu (if (stream-null? commands)
422 665c255d 2023-08-04 jrmu the-empty-stream
423 665c255d 2023-08-04 jrmu (cons-stream (choose initial-seed (stream-car commands))
424 665c255d 2023-08-04 jrmu (stream-map choose
425 665c255d 2023-08-04 jrmu (random-number-generator (stream-cdr commands))
426 665c255d 2023-08-04 jrmu (stream-cdr commands)))))
427 665c255d 2023-08-04 jrmu
428 665c255d 2023-08-04 jrmu (define random-commands '(gen gen gen gen gen (reset 137) gen gen gen (reset 293123) gen gen gen gen (reset 293123) gen gen gen gen (reset 137) gen gen gen gen gen gen))
429 665c255d 2023-08-04 jrmu (define random-numbers (random-number-generator (list->stream random-commands)))
430 665c255d 2023-08-04 jrmu
431 665c255d 2023-08-04 jrmu (test-stream-list random-numbers random-commands)