1 665c255d 2023-08-04 jrmu (define (ambeval exp env succeed fail)
2 665c255d 2023-08-04 jrmu ((analyze exp) env succeed fail))
3 665c255d 2023-08-04 jrmu (define (analyze exp)
4 665c255d 2023-08-04 jrmu (cond ((self-evaluating? exp)
5 665c255d 2023-08-04 jrmu (analyze-self-evaluating exp))
6 665c255d 2023-08-04 jrmu ((quoted? exp) (analyze-quoted exp))
7 665c255d 2023-08-04 jrmu ((variable? exp) (analyze-variable exp))
8 665c255d 2023-08-04 jrmu ((assignment? exp) (analyze-assignment exp))
9 665c255d 2023-08-04 jrmu ((permanent-assignment? exp)
10 665c255d 2023-08-04 jrmu (analyze-permanent-assignment exp))
11 665c255d 2023-08-04 jrmu ((definition? exp) (analyze-definition exp))
12 665c255d 2023-08-04 jrmu ((if? exp) (analyze-if exp))
13 665c255d 2023-08-04 jrmu ((and? exp) (analyze (and->if exp)))
14 665c255d 2023-08-04 jrmu ((or? exp) (analyze (or->if exp)))
15 665c255d 2023-08-04 jrmu ((not? exp) (analyze (not->if exp)))
16 665c255d 2023-08-04 jrmu ((xor? exp) (analyze (xor->or-and-not exp)))
17 665c255d 2023-08-04 jrmu ((lambda? exp) (analyze-lambda exp))
18 665c255d 2023-08-04 jrmu ((let? exp) (analyze (let->combination exp)))
19 665c255d 2023-08-04 jrmu ((let*? exp) (analyze (let*->nested-lets exp)))
20 665c255d 2023-08-04 jrmu ((named-let? exp) (analyze (named-let->combination exp)))
21 665c255d 2023-08-04 jrmu ((letrec? exp) (analyze (letrec->let exp)))
22 665c255d 2023-08-04 jrmu ((do? exp) (analyze (do->combination exp)))
23 665c255d 2023-08-04 jrmu ((begin? exp) (analyze-sequence (begin-actions exp)))
24 665c255d 2023-08-04 jrmu ((cond? exp) (analyze (cond->if exp)))
25 665c255d 2023-08-04 jrmu ((amb? exp) (analyze-amb exp))
26 665c255d 2023-08-04 jrmu ((ramb? exp) (analyze (ramb->amb exp)))
27 665c255d 2023-08-04 jrmu ((if-fail? exp) (analyze-if-fail exp))
28 665c255d 2023-08-04 jrmu ;; ((if-fail? exp) (analyze (if-fail->amb exp)))
29 665c255d 2023-08-04 jrmu ((application? exp) (analyze-application exp))
31 665c255d 2023-08-04 jrmu (error "Unknown expression type -- ANALYZE" exp))))
34 665c255d 2023-08-04 jrmu ;; analyzing procedures
35 665c255d 2023-08-04 jrmu (define (analyze-self-evaluating exp)
36 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
37 665c255d 2023-08-04 jrmu (succeed exp fail)))
38 665c255d 2023-08-04 jrmu (define (analyze-quoted exp)
39 665c255d 2023-08-04 jrmu (let ((qval (text-of-quotation exp)))
40 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
41 665c255d 2023-08-04 jrmu (succeed qval fail))))
42 665c255d 2023-08-04 jrmu (define (analyze-variable exp)
43 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
44 665c255d 2023-08-04 jrmu (succeed (lookup-variable-value exp env)
46 665c255d 2023-08-04 jrmu (define (analyze-lambda exp)
47 665c255d 2023-08-04 jrmu (let ((vars (lambda-parameters exp))
48 665c255d 2023-08-04 jrmu (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
49 665c255d 2023-08-04 jrmu ;; (bproc (analyze-sequence (lambda-body exp))))
50 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
51 665c255d 2023-08-04 jrmu (succeed (make-procedure vars bproc env)
53 665c255d 2023-08-04 jrmu (define (analyze-if exp)
54 665c255d 2023-08-04 jrmu (let ((pproc (analyze (if-predicate exp)))
55 665c255d 2023-08-04 jrmu (cproc (analyze (if-consequent exp)))
56 665c255d 2023-08-04 jrmu (aproc (analyze (if-alternative exp))))
57 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
59 665c255d 2023-08-04 jrmu ;; success continuation for evaluating the predicate
60 665c255d 2023-08-04 jrmu ;; to obtain pred-value
61 665c255d 2023-08-04 jrmu (lambda (pred-value fail2)
62 665c255d 2023-08-04 jrmu (if (true? pred-value)
63 665c255d 2023-08-04 jrmu (cproc env succeed fail2)
64 665c255d 2023-08-04 jrmu (aproc env succeed fail2)))
65 665c255d 2023-08-04 jrmu ;; failure continuation for evaluating the predicate
67 665c255d 2023-08-04 jrmu (define (analyze-if-fail exp)
68 665c255d 2023-08-04 jrmu (let ((dproc (analyze (if-fail-default exp)))
69 665c255d 2023-08-04 jrmu (aproc (analyze (if-fail-alternative exp))))
70 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
74 665c255d 2023-08-04 jrmu (aproc env succeed fail))))))
75 665c255d 2023-08-04 jrmu (define (analyze-sequence exps)
76 665c255d 2023-08-04 jrmu (define (sequentially a b)
77 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
79 665c255d 2023-08-04 jrmu ;; success continuation for calling a
80 665c255d 2023-08-04 jrmu (lambda (a-value fail2)
81 665c255d 2023-08-04 jrmu (b env succeed fail2))
82 665c255d 2023-08-04 jrmu ;; failure continuation for calling a
84 665c255d 2023-08-04 jrmu (define (loop first-proc rest-procs)
85 665c255d 2023-08-04 jrmu (if (null? rest-procs)
87 665c255d 2023-08-04 jrmu (loop (sequentially first-proc (car rest-procs))
88 665c255d 2023-08-04 jrmu (cdr rest-procs))))
89 665c255d 2023-08-04 jrmu (let ((procs (map analyze exps)))
90 665c255d 2023-08-04 jrmu (if (null? procs)
91 665c255d 2023-08-04 jrmu (error "Empty sequence -- ANALYZE"))
92 665c255d 2023-08-04 jrmu (loop (car procs) (cdr procs))))
93 665c255d 2023-08-04 jrmu (define (analyze-definition exp)
94 665c255d 2023-08-04 jrmu (let ((var (definition-variable exp))
95 665c255d 2023-08-04 jrmu (vproc (analyze (definition-value exp))))
96 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
98 665c255d 2023-08-04 jrmu (lambda (val fail2)
99 665c255d 2023-08-04 jrmu (define-variable! var val env)
100 665c255d 2023-08-04 jrmu (succeed 'ok fail2))
102 665c255d 2023-08-04 jrmu (define (analyze-assignment exp)
103 665c255d 2023-08-04 jrmu (let ((var (assignment-variable exp))
104 665c255d 2023-08-04 jrmu (vproc (analyze (assignment-value exp))))
105 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
107 665c255d 2023-08-04 jrmu (lambda (val fail2) ; *1*
108 665c255d 2023-08-04 jrmu (let ((old-value
109 665c255d 2023-08-04 jrmu (lookup-variable-value var env)))
110 665c255d 2023-08-04 jrmu (set-variable-value! var val env)
111 665c255d 2023-08-04 jrmu (succeed 'ok
112 665c255d 2023-08-04 jrmu (lambda () ; *2*
113 665c255d 2023-08-04 jrmu (set-variable-value! var
116 665c255d 2023-08-04 jrmu (fail2)))))
118 665c255d 2023-08-04 jrmu (define (analyze-permanent-assignment exp)
119 665c255d 2023-08-04 jrmu (let ((var (permanent-assignment-variable exp))
120 665c255d 2023-08-04 jrmu (vproc (analyze (permanent-assignment-value exp))))
121 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
124 665c255d 2023-08-04 jrmu (lambda (val val-fail)
125 665c255d 2023-08-04 jrmu (set-variable-value! var val env)
126 665c255d 2023-08-04 jrmu (succeed 'ok val-fail))
129 665c255d 2023-08-04 jrmu (define (analyze-application exp)
130 665c255d 2023-08-04 jrmu (let ((fproc (analyze (operator exp)))
131 665c255d 2023-08-04 jrmu (aprocs (map analyze (operands exp))))
132 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
134 665c255d 2023-08-04 jrmu (lambda (proc fail2)
135 665c255d 2023-08-04 jrmu (get-args aprocs
137 665c255d 2023-08-04 jrmu (lambda (args fail3)
138 665c255d 2023-08-04 jrmu (execute-application
139 665c255d 2023-08-04 jrmu proc args succeed fail3))
142 665c255d 2023-08-04 jrmu (define (get-args aprocs env succeed fail)
143 665c255d 2023-08-04 jrmu (if (null? aprocs)
144 665c255d 2023-08-04 jrmu (succeed '() fail)
145 665c255d 2023-08-04 jrmu ((car aprocs) env
146 665c255d 2023-08-04 jrmu ;; success continuation for this aproc
147 665c255d 2023-08-04 jrmu (lambda (arg fail2)
148 665c255d 2023-08-04 jrmu (get-args (cdr aprocs)
150 665c255d 2023-08-04 jrmu ;; success continuation for recursive
151 665c255d 2023-08-04 jrmu ;; call to get-args
152 665c255d 2023-08-04 jrmu (lambda (args fail3)
153 665c255d 2023-08-04 jrmu (succeed (cons arg args)
158 665c255d 2023-08-04 jrmu (define (analyze-amb exp)
159 665c255d 2023-08-04 jrmu (let ((cprocs (map analyze (amb-choices exp))))
160 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
161 665c255d 2023-08-04 jrmu (define (try-next choices)
162 665c255d 2023-08-04 jrmu (if (null? choices)
164 665c255d 2023-08-04 jrmu ((car choices) env
167 665c255d 2023-08-04 jrmu (try-next (cdr choices))))))
168 665c255d 2023-08-04 jrmu (try-next cprocs))))
175 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
176 665c255d 2023-08-04 jrmu (if (pair? exp)
177 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
180 665c255d 2023-08-04 jrmu ;; amb/ramb
181 665c255d 2023-08-04 jrmu (define (amb? exp) (tagged-list? exp 'amb))
182 665c255d 2023-08-04 jrmu (define (amb-choices exp) (cdr exp))
183 665c255d 2023-08-04 jrmu (define (make-amb choices)
184 665c255d 2023-08-04 jrmu (cons 'amb choices))
186 665c255d 2023-08-04 jrmu (define (ramb? exp)
187 665c255d 2023-08-04 jrmu (tagged-list? exp 'ramb))
188 665c255d 2023-08-04 jrmu (define (ramb->amb exp)
189 665c255d 2023-08-04 jrmu (make-amb (shuffle (amb-choices exp))))
191 665c255d 2023-08-04 jrmu (define (shuffle items)
192 665c255d 2023-08-04 jrmu (if (null? items)
194 665c255d 2023-08-04 jrmu (let ((first (list-ref items (random (length items)))))
195 665c255d 2023-08-04 jrmu (cons first
196 665c255d 2023-08-04 jrmu (shuffle (remove (lambda (i) (eq? first i))
197 665c255d 2023-08-04 jrmu items))))))
201 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
202 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
203 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
204 665c255d 2023-08-04 jrmu ((string? exp) true)
205 665c255d 2023-08-04 jrmu (else false)))
206 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
207 665c255d 2023-08-04 jrmu (define (quoted? exp)
208 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
209 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
211 665c255d 2023-08-04 jrmu ;; assignment/permanent-assignment/definition
212 665c255d 2023-08-04 jrmu (define (assignment? exp)
213 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
214 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
215 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
216 665c255d 2023-08-04 jrmu (define (make-assignment var val)
217 665c255d 2023-08-04 jrmu (list 'set! var val))
218 665c255d 2023-08-04 jrmu (define (permanent-assignment? exp)
219 665c255d 2023-08-04 jrmu (tagged-list? exp 'permanent-set!))
220 665c255d 2023-08-04 jrmu (define permanent-assignment-variable assignment-variable)
221 665c255d 2023-08-04 jrmu (define permanent-assignment-value assignment-value)
222 665c255d 2023-08-04 jrmu (define (definition? exp)
223 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
224 665c255d 2023-08-04 jrmu (define (definition-variable exp)
225 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
227 665c255d 2023-08-04 jrmu (caadr exp)))
228 665c255d 2023-08-04 jrmu (define (definition-value exp)
229 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
230 665c255d 2023-08-04 jrmu (caddr exp)
231 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
232 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
233 665c255d 2023-08-04 jrmu (define (make-definition var val)
234 665c255d 2023-08-04 jrmu `(define ,var ,val))
236 665c255d 2023-08-04 jrmu ;; if/and/or/not/xor/if-fail
237 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
238 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
239 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
240 665c255d 2023-08-04 jrmu (define (if-alternative exp)
241 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
242 665c255d 2023-08-04 jrmu (cadddr exp)
244 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
245 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
247 665c255d 2023-08-04 jrmu (define (and? exp)
248 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
249 665c255d 2023-08-04 jrmu (define (and-clauses exp)
251 665c255d 2023-08-04 jrmu (define (or? exp)
252 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
253 665c255d 2023-08-04 jrmu (define (or-clauses exp)
255 665c255d 2023-08-04 jrmu (define (and->if exp)
256 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
257 665c255d 2023-08-04 jrmu (cond ((null? clauses) 'true)
258 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (car clauses))
259 665c255d 2023-08-04 jrmu (else (make-if (car clauses)
260 665c255d 2023-08-04 jrmu (expand-clauses (cdr clauses))
262 665c255d 2023-08-04 jrmu (expand-clauses (and-clauses exp)))
263 665c255d 2023-08-04 jrmu (define (or->if exp)
264 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
265 665c255d 2023-08-04 jrmu (if (null? clauses)
267 665c255d 2023-08-04 jrmu (make-if (car clauses)
268 665c255d 2023-08-04 jrmu (car clauses)
269 665c255d 2023-08-04 jrmu (expand-clauses (cdr clauses)))))
270 665c255d 2023-08-04 jrmu (expand-clauses (or-clauses exp)))
271 665c255d 2023-08-04 jrmu (define (not? exp)
272 665c255d 2023-08-04 jrmu (tagged-list? exp 'not))
273 665c255d 2023-08-04 jrmu (define (not->if exp)
274 665c255d 2023-08-04 jrmu `(if ,(cadr exp) false true))
275 665c255d 2023-08-04 jrmu (define (xor? exp)
276 665c255d 2023-08-04 jrmu (tagged-list? exp 'xor))
277 665c255d 2023-08-04 jrmu (define (xor->or-and-not exp)
278 665c255d 2023-08-04 jrmu (let ((pred-1 (cadr exp))
279 665c255d 2023-08-04 jrmu (pred-2 (caddr exp)))
280 665c255d 2023-08-04 jrmu `(or (and ,pred-1 (not ,pred-2))
281 665c255d 2023-08-04 jrmu (and (not ,pred-1) ,pred-2))))
282 665c255d 2023-08-04 jrmu ;; (define (if-fail->amb exp)
283 665c255d 2023-08-04 jrmu ;; (make-amb (list (if-fail-default exp)
284 665c255d 2023-08-04 jrmu ;; (if-fail-alternative exp))))
285 665c255d 2023-08-04 jrmu (define (if-fail? exp)
286 665c255d 2023-08-04 jrmu (tagged-list? exp 'if-fail))
287 665c255d 2023-08-04 jrmu (define (if-fail-default exp)
288 665c255d 2023-08-04 jrmu (cadr exp))
289 665c255d 2023-08-04 jrmu (define (if-fail-alternative exp)
290 665c255d 2023-08-04 jrmu (caddr exp))
292 665c255d 2023-08-04 jrmu ;; lambda/let/let*/letrec
293 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
294 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
295 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
296 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
297 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
299 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
301 665c255d 2023-08-04 jrmu (cons (map list vars vals)
303 665c255d 2023-08-04 jrmu (define (let? exp)
304 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
305 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
306 665c255d 2023-08-04 jrmu (define (let-vars exp)
307 665c255d 2023-08-04 jrmu (map car (cadr exp)))
308 665c255d 2023-08-04 jrmu (define (let-vals exp)
309 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
310 665c255d 2023-08-04 jrmu (define (let-body exp)
311 665c255d 2023-08-04 jrmu (cddr exp))
312 665c255d 2023-08-04 jrmu (define (let->combination exp)
313 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
314 665c255d 2023-08-04 jrmu (let-vals exp)))
315 665c255d 2023-08-04 jrmu (define (named-let? exp)
316 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
317 665c255d 2023-08-04 jrmu v (symbol? (cadr exp))))
318 665c255d 2023-08-04 jrmu (define (named-let-name exp)
319 665c255d 2023-08-04 jrmu (cadr exp))
320 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
321 665c255d 2023-08-04 jrmu (map car (caddr exp)))
322 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
323 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
324 665c255d 2023-08-04 jrmu (define (named-let-body exp)
325 665c255d 2023-08-04 jrmu (cdddr exp))
326 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
327 665c255d 2023-08-04 jrmu (sequence->exp
328 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
329 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
330 665c255d 2023-08-04 jrmu (named-let-body exp)))
331 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
332 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
333 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
336 665c255d 2023-08-04 jrmu (cons (map list vars vals)
339 665c255d 2023-08-04 jrmu (define (letrec? exp)
340 665c255d 2023-08-04 jrmu (tagged-list? exp 'letrec))
342 665c255d 2023-08-04 jrmu (define (letrec-vars exp)
343 665c255d 2023-08-04 jrmu (map car (cadr exp)))
344 665c255d 2023-08-04 jrmu (define (letrec-vals exp)
345 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
346 665c255d 2023-08-04 jrmu (define (letrec-body exp)
347 665c255d 2023-08-04 jrmu (cddr exp))
348 665c255d 2023-08-04 jrmu (define (letrec->let exp)
349 665c255d 2023-08-04 jrmu (let* ((vars (letrec-vars exp))
350 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
352 665c255d 2023-08-04 jrmu (vals (letrec-vals exp))
353 665c255d 2023-08-04 jrmu (assignments (map (lambda (var val)
354 665c255d 2023-08-04 jrmu (make-assignment var val))
357 665c255d 2023-08-04 jrmu (body (letrec-body exp)))
358 665c255d 2023-08-04 jrmu (make-let vars
359 665c255d 2023-08-04 jrmu unassigneds
360 665c255d 2023-08-04 jrmu (append assignments body))))
362 665c255d 2023-08-04 jrmu (define (make-application op args)
363 665c255d 2023-08-04 jrmu (cons op args))
365 665c255d 2023-08-04 jrmu (define (let*? exp)
366 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
367 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
368 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
369 665c255d 2023-08-04 jrmu (define let*-body let-body)
370 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
371 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
372 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
373 665c255d 2023-08-04 jrmu (make-let (list (car vars))
374 665c255d 2023-08-04 jrmu (list (car vals))
375 665c255d 2023-08-04 jrmu (let*-body exp))
376 665c255d 2023-08-04 jrmu (make-let (list (car vars))
377 665c255d 2023-08-04 jrmu (list (car vals))
378 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
379 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
380 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
381 665c255d 2023-08-04 jrmu (if (null? vars)
382 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
383 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
386 665c255d 2023-08-04 jrmu (define (do? exp)
387 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
388 665c255d 2023-08-04 jrmu (define (do-vars exp)
389 665c255d 2023-08-04 jrmu (map car (cadr exp)))
390 665c255d 2023-08-04 jrmu (define (do-inits exp)
391 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
392 665c255d 2023-08-04 jrmu (define (do-steps exp)
393 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
394 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
395 665c255d 2023-08-04 jrmu (car var-init-step)
396 665c255d 2023-08-04 jrmu (caddr var-init-step)))
397 665c255d 2023-08-04 jrmu (cadr exp)))
398 665c255d 2023-08-04 jrmu (define (do-test exp)
399 665c255d 2023-08-04 jrmu (caaddr exp))
400 665c255d 2023-08-04 jrmu (define (do-expressions exp)
401 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
402 665c255d 2023-08-04 jrmu (caddr exp)
403 665c255d 2023-08-04 jrmu (cdaddr exp)))
404 665c255d 2023-08-04 jrmu (define (do-commands exp)
405 665c255d 2023-08-04 jrmu (cdddr exp))
406 665c255d 2023-08-04 jrmu (define (do->combination exp)
407 665c255d 2023-08-04 jrmu (make-named-let
409 665c255d 2023-08-04 jrmu (do-vars exp)
410 665c255d 2023-08-04 jrmu (do-inits exp)
413 665c255d 2023-08-04 jrmu (do-test exp)
414 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
415 665c255d 2023-08-04 jrmu (sequence->exp
416 665c255d 2023-08-04 jrmu (append (do-commands exp)
417 665c255d 2023-08-04 jrmu (list (make-application
419 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
422 665c255d 2023-08-04 jrmu ;; begin/sequence
423 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
424 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
425 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
426 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
427 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
428 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
429 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
430 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
431 665c255d 2023-08-04 jrmu (else (make-begin seq))))
432 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
434 665c255d 2023-08-04 jrmu ;; application
435 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
436 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
437 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
438 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
439 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
440 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
443 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
444 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
445 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
446 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
447 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
448 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
449 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
450 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
451 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
452 665c255d 2023-08-04 jrmu (caddr clause))
453 665c255d 2023-08-04 jrmu (define (cond->if exp)
454 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
455 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
456 665c255d 2023-08-04 jrmu (if (null? clauses)
457 665c255d 2023-08-04 jrmu 'false ; no else clause
458 665c255d 2023-08-04 jrmu (let ((first (car clauses))
459 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
460 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
461 665c255d 2023-08-04 jrmu (if (null? rest)
462 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
463 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
465 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
466 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
467 665c255d 2023-08-04 jrmu (make-application
468 665c255d 2023-08-04 jrmu (cond-extended-proc first)
469 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
470 665c255d 2023-08-04 jrmu (expand-clauses rest))
471 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
472 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
473 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
474 665c255d 2023-08-04 jrmu (define (true? x)
475 665c255d 2023-08-04 jrmu (not (eq? x false)))
476 665c255d 2023-08-04 jrmu (define (false? x)
477 665c255d 2023-08-04 jrmu (eq? x false))
479 665c255d 2023-08-04 jrmu ;; procedure
480 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
481 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
482 665c255d 2023-08-04 jrmu (define (scan-out-defines body)
483 665c255d 2023-08-04 jrmu (let* ((definitions (filter definition? body))
484 665c255d 2023-08-04 jrmu (vars (map definition-variable definitions))
485 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
487 665c255d 2023-08-04 jrmu (vals (map definition-value definitions))
488 665c255d 2023-08-04 jrmu (assignments
489 665c255d 2023-08-04 jrmu (map (lambda (var val)
490 665c255d 2023-08-04 jrmu (make-assignment var val))
491 665c255d 2023-08-04 jrmu vars vals))
492 665c255d 2023-08-04 jrmu (exps (remove definition? body)))
493 665c255d 2023-08-04 jrmu (if (null? definitions)
496 665c255d 2023-08-04 jrmu (make-let vars
497 665c255d 2023-08-04 jrmu unassigneds
498 665c255d 2023-08-04 jrmu (append assignments exps))))))
499 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
500 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
501 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
502 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
503 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
505 665c255d 2023-08-04 jrmu ;; environment
506 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
507 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
508 665c255d 2023-08-04 jrmu (define the-empty-environment '())
509 665c255d 2023-08-04 jrmu (define (make-frame variables values)
510 665c255d 2023-08-04 jrmu (cons variables values))
511 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
512 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
513 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
514 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
515 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
516 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
517 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
518 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
519 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
520 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
521 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
522 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
523 665c255d 2023-08-04 jrmu (define (env-loop env)
524 665c255d 2023-08-04 jrmu (define (scan vars vals)
525 665c255d 2023-08-04 jrmu (cond ((null? vars)
526 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
527 665c255d 2023-08-04 jrmu ((eq? var (car vars))
528 665c255d 2023-08-04 jrmu ;; (let ((val (car vals)))
529 665c255d 2023-08-04 jrmu ;; (if (eq? val '*unassigned*)
530 665c255d 2023-08-04 jrmu ;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
532 665c255d 2023-08-04 jrmu (car vals))
533 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
534 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
535 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
536 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
537 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
538 665c255d 2023-08-04 jrmu (frame-values frame)))))
539 665c255d 2023-08-04 jrmu (env-loop env))
540 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
541 665c255d 2023-08-04 jrmu (define (env-loop env)
542 665c255d 2023-08-04 jrmu (define (scan vars vals)
543 665c255d 2023-08-04 jrmu (cond ((null? vars)
544 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
545 665c255d 2023-08-04 jrmu ((eq? var (car vars))
546 665c255d 2023-08-04 jrmu (set-car! vals val))
547 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
548 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
549 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
550 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
551 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
552 665c255d 2023-08-04 jrmu (frame-values frame)))))
553 665c255d 2023-08-04 jrmu (env-loop env))
554 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
555 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
556 665c255d 2023-08-04 jrmu (define (scan vars vals)
557 665c255d 2023-08-04 jrmu (cond ((null? vars)
558 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
559 665c255d 2023-08-04 jrmu ((eq? var (car vars))
560 665c255d 2023-08-04 jrmu (set-car! vals val))
561 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
562 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
563 665c255d 2023-08-04 jrmu (frame-values frame))))
565 665c255d 2023-08-04 jrmu ;; (define (remove-binding-from-frame! var frame)
566 665c255d 2023-08-04 jrmu ;; (define (scan vars vals)
567 665c255d 2023-08-04 jrmu ;; (cond ((null? (cdr vars))
568 665c255d 2023-08-04 jrmu ;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
569 665c255d 2023-08-04 jrmu ;; ((eq? var (cadr vars))
570 665c255d 2023-08-04 jrmu ;; (set-cdr! vars (cddr vars))
571 665c255d 2023-08-04 jrmu ;; (set-cdr! vals (cddr vals)))
572 665c255d 2023-08-04 jrmu ;; (else (scan (cdr vars) (cdr vals)))))
573 665c255d 2023-08-04 jrmu ;; (let ((vars (frame-variables frame))
574 665c255d 2023-08-04 jrmu ;; (vals (frame-values frame)))
575 665c255d 2023-08-04 jrmu ;; (if (eq? var (car vars))
576 665c255d 2023-08-04 jrmu ;; (begin (set-car! frame (cdr vars))
577 665c255d 2023-08-04 jrmu ;; (set-cdr! frame (cdr vals)))
578 665c255d 2023-08-04 jrmu ;; (scan vars vals))))
580 665c255d 2023-08-04 jrmu ;; primitives
581 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
582 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
583 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
584 665c255d 2023-08-04 jrmu (define primitive-procedures
585 665c255d 2023-08-04 jrmu (list (list 'car car)
586 665c255d 2023-08-04 jrmu (list 'cdr cdr)
587 665c255d 2023-08-04 jrmu (list 'caar caar)
588 665c255d 2023-08-04 jrmu (list 'cadr cadr)
589 665c255d 2023-08-04 jrmu (list 'cddr cddr)
590 665c255d 2023-08-04 jrmu (list 'caddr caddr)
591 665c255d 2023-08-04 jrmu (list 'cdddr cdddr)
592 665c255d 2023-08-04 jrmu (list 'cons cons)
593 665c255d 2023-08-04 jrmu (list 'list list)
594 665c255d 2023-08-04 jrmu (list 'null? null?)
595 665c255d 2023-08-04 jrmu (list 'pair? pair?)
596 665c255d 2023-08-04 jrmu (list '* *)
597 665c255d 2023-08-04 jrmu (list '/ /)
598 665c255d 2023-08-04 jrmu (list '+ +)
599 665c255d 2023-08-04 jrmu (list '- -)
600 665c255d 2023-08-04 jrmu (list '= =)
601 665c255d 2023-08-04 jrmu (list '< <)
602 665c255d 2023-08-04 jrmu (list '> >)
603 665c255d 2023-08-04 jrmu (list '<= <=)
604 665c255d 2023-08-04 jrmu (list '>= >=)
605 665c255d 2023-08-04 jrmu (list 'abs abs)
606 665c255d 2023-08-04 jrmu (list 'remainder remainder)
607 665c255d 2023-08-04 jrmu (list 'even? even?)
608 665c255d 2023-08-04 jrmu (list 'eq? eq?)
609 665c255d 2023-08-04 jrmu (list 'equal? equal?)
610 665c255d 2023-08-04 jrmu (list 'member member)
611 665c255d 2023-08-04 jrmu (list 'memq memq)
612 665c255d 2023-08-04 jrmu (list 'display display)
613 665c255d 2023-08-04 jrmu (list 'error error)))
614 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
616 665c255d 2023-08-04 jrmu primitive-procedures))
617 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
618 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
619 665c255d 2023-08-04 jrmu primitive-procedures))
620 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
622 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
624 665c255d 2023-08-04 jrmu ;; execute application
626 665c255d 2023-08-04 jrmu (define (execute-application proc args succeed fail)
627 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? proc)
628 665c255d 2023-08-04 jrmu (succeed (apply-primitive-procedure proc args)
630 665c255d 2023-08-04 jrmu ((compound-procedure? proc)
631 665c255d 2023-08-04 jrmu ((procedure-body proc)
632 665c255d 2023-08-04 jrmu (extend-environment (procedure-parameters proc)
634 665c255d 2023-08-04 jrmu (procedure-environment proc))
639 665c255d 2023-08-04 jrmu "Unknown procedure type -- EXECUTE-APPLICATION"
643 665c255d 2023-08-04 jrmu ;; driver-loop
644 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
645 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
646 665c255d 2023-08-04 jrmu (define (announce-output string)
647 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
648 665c255d 2023-08-04 jrmu (define (user-print object)
649 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
650 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
651 665c255d 2023-08-04 jrmu (procedure-parameters object)
652 665c255d 2023-08-04 jrmu (procedure-body object)
653 665c255d 2023-08-04 jrmu '<procedure-env>))
654 665c255d 2023-08-04 jrmu (display object)))
655 665c255d 2023-08-04 jrmu (define (setup-environment)
656 665c255d 2023-08-04 jrmu (let ((initial-env
657 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
658 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
659 665c255d 2023-08-04 jrmu the-empty-environment)))
660 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
661 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
662 665c255d 2023-08-04 jrmu initial-env))
663 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
665 665c255d 2023-08-04 jrmu (define input-prompt ";;; Amb-Eval input:")
666 665c255d 2023-08-04 jrmu (define output-prompt ";;; Amb-Eval value:")
667 665c255d 2023-08-04 jrmu (define (driver-loop)
668 665c255d 2023-08-04 jrmu (define (internal-loop try-again)
669 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
670 665c255d 2023-08-04 jrmu (let ((input (read)))
671 665c255d 2023-08-04 jrmu (if (eq? input 'try-again)
672 665c255d 2023-08-04 jrmu (try-again)
675 665c255d 2023-08-04 jrmu (display ";;; Starting a new problem ")
676 665c255d 2023-08-04 jrmu (ambeval input
677 665c255d 2023-08-04 jrmu the-global-environment
678 665c255d 2023-08-04 jrmu ;; ambeval success
679 665c255d 2023-08-04 jrmu (lambda (val next-alternative)
680 665c255d 2023-08-04 jrmu (announce-output output-prompt)
681 665c255d 2023-08-04 jrmu (user-print val)
682 665c255d 2023-08-04 jrmu (internal-loop next-alternative))
683 665c255d 2023-08-04 jrmu ;; ambeval failure
685 665c255d 2023-08-04 jrmu (announce-output
686 665c255d 2023-08-04 jrmu ";;; There are no more values of")
687 665c255d 2023-08-04 jrmu (user-print input)
688 665c255d 2023-08-04 jrmu (driver-loop)))))))
689 665c255d 2023-08-04 jrmu (internal-loop
692 665c255d 2023-08-04 jrmu (display ";;; There is no current problem")
693 665c255d 2023-08-04 jrmu (driver-loop))))
696 665c255d 2023-08-04 jrmu ;; auxiliary
697 665c255d 2023-08-04 jrmu (define (test-case actual expected)
699 665c255d 2023-08-04 jrmu (display "Actual: ")
700 665c255d 2023-08-04 jrmu (display actual)
702 665c255d 2023-08-04 jrmu (display "Expected: ")
703 665c255d 2023-08-04 jrmu (display expected)
705 665c255d 2023-08-04 jrmu (define try-again
707 665c255d 2023-08-04 jrmu "No current problem"))
708 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
709 665c255d 2023-08-04 jrmu (if (eq? exp 'try-again)
710 665c255d 2023-08-04 jrmu (try-again)
711 665c255d 2023-08-04 jrmu (ambeval exp
712 665c255d 2023-08-04 jrmu the-global-environment
713 665c255d 2023-08-04 jrmu (lambda (val next-alternative)
714 665c255d 2023-08-04 jrmu (set! try-again next-alternative)
717 665c255d 2023-08-04 jrmu (set! try-again
719 665c255d 2023-08-04 jrmu "No current problem"))
720 665c255d 2023-08-04 jrmu "No alternatives"))))
721 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
722 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
723 665c255d 2023-08-04 jrmu (define (print-eval exp)
724 665c255d 2023-08-04 jrmu (user-print (geval exp)))
726 665c255d 2023-08-04 jrmu ;; test-suite
728 665c255d 2023-08-04 jrmu ;; procedure definitions
731 665c255d 2023-08-04 jrmu '(define (append x y)
732 665c255d 2023-08-04 jrmu (if (null? x)
734 665c255d 2023-08-04 jrmu (cons (car x) (append (cdr x) y)))))
736 665c255d 2023-08-04 jrmu '(define (list-ref items n)
737 665c255d 2023-08-04 jrmu (if (= n 0)
738 665c255d 2023-08-04 jrmu (car items)
739 665c255d 2023-08-04 jrmu (list-ref (cdr items) (- n 1)))))
741 665c255d 2023-08-04 jrmu '(define (fold-left f init seq)
742 665c255d 2023-08-04 jrmu (if (null? seq)
744 665c255d 2023-08-04 jrmu (fold-left f
745 665c255d 2023-08-04 jrmu (f init (car seq))
746 665c255d 2023-08-04 jrmu (cdr seq)))))
748 665c255d 2023-08-04 jrmu '(define (enumerate-interval low high)
749 665c255d 2023-08-04 jrmu (if (> low high)
751 665c255d 2023-08-04 jrmu (cons low (enumerate-interval (+ low 1) high)))))
753 665c255d 2023-08-04 jrmu '(define (assoc key records)
754 665c255d 2023-08-04 jrmu (cond ((null? records) false)
755 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
756 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
759 665c255d 2023-08-04 jrmu '(define (map proc list)
760 665c255d 2023-08-04 jrmu (if (null? list)
762 665c255d 2023-08-04 jrmu (cons (proc (car list))
763 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
765 665c255d 2023-08-04 jrmu '(define (map-2 proc l1 l2)
766 665c255d 2023-08-04 jrmu (if (null? l1)
768 665c255d 2023-08-04 jrmu (cons (proc (car l1) (car l2))
769 665c255d 2023-08-04 jrmu (map-2 proc (cdr l1) (cdr l2))))))
772 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
773 665c255d 2023-08-04 jrmu (if (null? sequence)
775 665c255d 2023-08-04 jrmu (op (car sequence)
776 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
778 665c255d 2023-08-04 jrmu ;; ;; ;; all special forms
779 665c255d 2023-08-04 jrmu ;; (test-eval '(begin 5 6) 6)
780 665c255d 2023-08-04 jrmu ;; (test-eval '10 10)
781 665c255d 2023-08-04 jrmu ;; (geval '(define x 3))
782 665c255d 2023-08-04 jrmu ;; (test-eval 'x 3)
783 665c255d 2023-08-04 jrmu ;; (test-eval '(set! x -25) 'ok)
784 665c255d 2023-08-04 jrmu ;; (test-eval 'x -25)
785 665c255d 2023-08-04 jrmu ;; (geval '(define z (lambda (x y) (+ x (* x y)))))
786 665c255d 2023-08-04 jrmu ;; (test-eval '(z 3 4) 15)
787 665c255d 2023-08-04 jrmu ;; (test-eval '(cond ((= x -2) 'x=-2)
788 665c255d 2023-08-04 jrmu ;; ((= x -25) 'x=-25)
789 665c255d 2023-08-04 jrmu ;; (else 'failed))
791 665c255d 2023-08-04 jrmu ;; (test-eval '(if true false true) false)
793 665c255d 2023-08-04 jrmu ;; (test-eval
794 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 7))
795 665c255d 2023-08-04 jrmu ;; (+ x y (* x y)))
796 665c255d 2023-08-04 jrmu ;; (+ 4 7 (* 4 7)))
799 665c255d 2023-08-04 jrmu ;; ;; and/or
800 665c255d 2023-08-04 jrmu ;; (geval '(define x (+ 3 8)))
801 665c255d 2023-08-04 jrmu ;; (test-eval '(and 0 true x) 11)
802 665c255d 2023-08-04 jrmu ;; (test-eval '(and 0 true x false) false)
803 665c255d 2023-08-04 jrmu ;; (test-eval '(and 0 true x (set! x -2) false) false)
804 665c255d 2023-08-04 jrmu ;; (test-eval 'x -2)
805 665c255d 2023-08-04 jrmu ;; (test-eval '(and 0 true x false (set! x -5)) false)
806 665c255d 2023-08-04 jrmu ;; (test-eval 'x -2)
807 665c255d 2023-08-04 jrmu ;; (test-eval '(or false (set! x 25)) 'ok)
808 665c255d 2023-08-04 jrmu ;; (test-eval 'x 25)
809 665c255d 2023-08-04 jrmu ;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
810 665c255d 2023-08-04 jrmu ;; (test-eval 'x 2)
811 665c255d 2023-08-04 jrmu ;; (test-eval '(or false (set! x 25) true false) 'ok)
812 665c255d 2023-08-04 jrmu ;; (test-eval 'x 25)
813 665c255d 2023-08-04 jrmu ;; (test-eval '(or ((lambda (x) x) 5)) 5)
814 665c255d 2023-08-04 jrmu ;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
815 665c255d 2023-08-04 jrmu ;; (newline)
816 665c255d 2023-08-04 jrmu ;; (display "Failure expected")
817 665c255d 2023-08-04 jrmu ;; (newline)
821 665c255d 2023-08-04 jrmu ;; (test-eval
822 665c255d 2023-08-04 jrmu ;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
823 665c255d 2023-08-04 jrmu ;; (else false))
826 665c255d 2023-08-04 jrmu ;; (test-eval
827 665c255d 2023-08-04 jrmu ;; '(cond ((= 3 4) 'not-true)
828 665c255d 2023-08-04 jrmu ;; ((= (* 2 4) 3) 'also-false)
829 665c255d 2023-08-04 jrmu ;; ((map (lambda (x)
830 665c255d 2023-08-04 jrmu ;; (* x (+ x 1)))
831 665c255d 2023-08-04 jrmu ;; '(2 4 1 9))
833 665c255d 2023-08-04 jrmu ;; (lambda (x)
834 665c255d 2023-08-04 jrmu ;; (accumulate + 0 x)))
835 665c255d 2023-08-04 jrmu ;; (else 'never-reach))
837 665c255d 2023-08-04 jrmu ;; ;; '(6 20 2 90)
840 665c255d 2023-08-04 jrmu ;; ;; procedure definition and application
842 665c255d 2023-08-04 jrmu ;; '(define (factorial n)
843 665c255d 2023-08-04 jrmu ;; (if (= n 0)
845 665c255d 2023-08-04 jrmu ;; (* n (factorial (- n 1))))))
846 665c255d 2023-08-04 jrmu ;; (test-eval '(factorial 5) 120)
850 665c255d 2023-08-04 jrmu ;; (test-eval
851 665c255d 2023-08-04 jrmu ;; '(map (lambda (x)
852 665c255d 2023-08-04 jrmu ;; (* x (+ x 1)))
853 665c255d 2023-08-04 jrmu ;; '(2 1 4 2 8 3))
854 665c255d 2023-08-04 jrmu ;; '(6 2 20 6 72 12))
855 665c255d 2023-08-04 jrmu ;; ;; accumulate
857 665c255d 2023-08-04 jrmu ;; (test-eval
858 665c255d 2023-08-04 jrmu ;; '(accumulate + 0 '(1 2 3 4 5))
861 665c255d 2023-08-04 jrmu ;; ;; make-let
862 665c255d 2023-08-04 jrmu ;; (test-eval
863 665c255d 2023-08-04 jrmu ;; (make-let '(x y) '(3 5) '((+ x y)))
865 665c255d 2023-08-04 jrmu ;; (test-eval
866 665c255d 2023-08-04 jrmu ;; '(let ()
869 665c255d 2023-08-04 jrmu ;; (test-eval
870 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
873 665c255d 2023-08-04 jrmu ;; (test-eval
874 665c255d 2023-08-04 jrmu ;; '(let ((x 3)
876 665c255d 2023-08-04 jrmu ;; (+ x y))
878 665c255d 2023-08-04 jrmu ;; (test-eval
879 665c255d 2023-08-04 jrmu ;; '(let ((x 3)
881 665c255d 2023-08-04 jrmu ;; (+ (let ((x (+ y 2))
883 665c255d 2023-08-04 jrmu ;; (* x y))
885 665c255d 2023-08-04 jrmu ;; (+ (* 4 3) 3 2))
886 665c255d 2023-08-04 jrmu ;; (test-eval
887 665c255d 2023-08-04 jrmu ;; '(let ((x 6)
888 665c255d 2023-08-04 jrmu ;; (y (let ((x 2))
889 665c255d 2023-08-04 jrmu ;; (+ x 3)))
890 665c255d 2023-08-04 jrmu ;; (z (let ((a (* 3 2)))
891 665c255d 2023-08-04 jrmu ;; (+ a 3))))
892 665c255d 2023-08-04 jrmu ;; (+ x y z))
893 665c255d 2023-08-04 jrmu ;; (+ 6 5 9))
898 665c255d 2023-08-04 jrmu ;; (test-eval
899 665c255d 2023-08-04 jrmu ;; '(let* ((x 3)
900 665c255d 2023-08-04 jrmu ;; (y (+ x 2))
901 665c255d 2023-08-04 jrmu ;; (z (+ x y 5)))
902 665c255d 2023-08-04 jrmu ;; (* x z))
905 665c255d 2023-08-04 jrmu ;; (test-eval
906 665c255d 2023-08-04 jrmu ;; '(let* ()
909 665c255d 2023-08-04 jrmu ;; (test-eval
910 665c255d 2023-08-04 jrmu ;; '(let* ((x 3))
911 665c255d 2023-08-04 jrmu ;; (let* ((y 5))
912 665c255d 2023-08-04 jrmu ;; (+ x y)))
915 665c255d 2023-08-04 jrmu ;; (test-eval
916 665c255d 2023-08-04 jrmu ;; '(let* ((x 3)
917 665c255d 2023-08-04 jrmu ;; (y (+ x 1)))
918 665c255d 2023-08-04 jrmu ;; (+ (let* ((x (+ y 2))
920 665c255d 2023-08-04 jrmu ;; (* x y))
922 665c255d 2023-08-04 jrmu ;; (+ (* 6 6) 3 4))
923 665c255d 2023-08-04 jrmu ;; (test-eval
924 665c255d 2023-08-04 jrmu ;; '(let* ((x 6)
925 665c255d 2023-08-04 jrmu ;; (y (let* ((x 2)
926 665c255d 2023-08-04 jrmu ;; (a (let* ((x (* 3 x)))
927 665c255d 2023-08-04 jrmu ;; (+ x 2))))
928 665c255d 2023-08-04 jrmu ;; (+ x a)))
929 665c255d 2023-08-04 jrmu ;; (z (+ x y)))
930 665c255d 2023-08-04 jrmu ;; (+ x y z))
933 665c255d 2023-08-04 jrmu ;; ;; named-let
935 665c255d 2023-08-04 jrmu ;; (test-eval
936 665c255d 2023-08-04 jrmu ;; '(let eight ()
941 665c255d 2023-08-04 jrmu ;; (test-eval
942 665c255d 2023-08-04 jrmu ;; '(let loop ((count 0))
943 665c255d 2023-08-04 jrmu ;; (if (= 100 count)
945 665c255d 2023-08-04 jrmu ;; (loop (+ count 1))))
948 665c255d 2023-08-04 jrmu ;; '(define (prime? x)
949 665c255d 2023-08-04 jrmu ;; (let prime-iter ((i 2))
950 665c255d 2023-08-04 jrmu ;; (cond ((> (* i i) x) true)
951 665c255d 2023-08-04 jrmu ;; ((= (remainder x i) 0) false)
952 665c255d 2023-08-04 jrmu ;; (else (prime-iter (+ i 1)))))))
953 665c255d 2023-08-04 jrmu ;; (test-eval
954 665c255d 2023-08-04 jrmu ;; '(let primes ((x 2)
956 665c255d 2023-08-04 jrmu ;; (cond ((= n 0) '())
957 665c255d 2023-08-04 jrmu ;; ((prime? x)
959 665c255d 2023-08-04 jrmu ;; (primes (+ x 1) (- n 1))))
960 665c255d 2023-08-04 jrmu ;; (else (primes (+ x 1) n))))
961 665c255d 2023-08-04 jrmu ;; '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
964 665c255d 2023-08-04 jrmu ;; '(define (fib n)
965 665c255d 2023-08-04 jrmu ;; (let fib-iter ((a 1)
967 665c255d 2023-08-04 jrmu ;; (count n))
968 665c255d 2023-08-04 jrmu ;; (if (= count 0)
970 665c255d 2023-08-04 jrmu ;; (fib-iter (+ a b) a (- count 1))))))
971 665c255d 2023-08-04 jrmu ;; (test-eval '(fib 19) 4181)
973 665c255d 2023-08-04 jrmu ;; ;; do-loop
974 665c255d 2023-08-04 jrmu ;; (test-eval
975 665c255d 2023-08-04 jrmu ;; '(let ((y 0))
976 665c255d 2023-08-04 jrmu ;; (do ((x 0 (+ x 1)))
977 665c255d 2023-08-04 jrmu ;; ((= x 5) y)
978 665c255d 2023-08-04 jrmu ;; (set! y (+ y 1))))
980 665c255d 2023-08-04 jrmu ;; (test-eval
984 665c255d 2023-08-04 jrmu ;; (test-eval
986 665c255d 2023-08-04 jrmu ;; (true 5))
988 665c255d 2023-08-04 jrmu ;; (test-eval
989 665c255d 2023-08-04 jrmu ;; '(let ((y 0))
991 665c255d 2023-08-04 jrmu ;; ((= y 5) y)
992 665c255d 2023-08-04 jrmu ;; (set! y (+ y 1))))
995 665c255d 2023-08-04 jrmu ;; (test-eval
996 665c255d 2023-08-04 jrmu ;; '(do ((y '(1 2 3 4)))
997 665c255d 2023-08-04 jrmu ;; ((null? y))
998 665c255d 2023-08-04 jrmu ;; (set! y (cdr y)))
1000 665c255d 2023-08-04 jrmu ;; (test-eval
1001 665c255d 2023-08-04 jrmu ;; '(let ((y 0))
1002 665c255d 2023-08-04 jrmu ;; (do ((x 0 (+ x 1)))
1003 665c255d 2023-08-04 jrmu ;; ((= x 5) y)
1004 665c255d 2023-08-04 jrmu ;; (set! y (+ y 1))))
1006 665c255d 2023-08-04 jrmu ;; (test-eval
1007 665c255d 2023-08-04 jrmu ;; '(let ((x '(1 3 5 7 9)))
1008 665c255d 2023-08-04 jrmu ;; (do ((x x (cdr x))
1009 665c255d 2023-08-04 jrmu ;; (sum 0 (+ sum (car x))))
1010 665c255d 2023-08-04 jrmu ;; ((null? x) sum)))
1012 665c255d 2023-08-04 jrmu ;; (test-eval
1013 665c255d 2023-08-04 jrmu ;; '(let ((z '()))
1014 665c255d 2023-08-04 jrmu ;; (do ((x '(1 2 3 4) (cdr x))
1015 665c255d 2023-08-04 jrmu ;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
1016 665c255d 2023-08-04 jrmu ;; ((null? x) y x z)
1017 665c255d 2023-08-04 jrmu ;; (set! z (cons (car x) z))))
1018 665c255d 2023-08-04 jrmu ;; '(4 3 2 1))
1022 665c255d 2023-08-04 jrmu ;; ;; make-unbound!
1023 665c255d 2023-08-04 jrmu ;; ;; broken now due to scan-out-defines
1025 665c255d 2023-08-04 jrmu ;; ;; (test-eval
1026 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 3))
1027 665c255d 2023-08-04 jrmu ;; ;; (let ((x 5))
1028 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
1029 665c255d 2023-08-04 jrmu ;; ;; (* x x)))
1032 665c255d 2023-08-04 jrmu ;; ;; (test-eval
1033 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 3))
1034 665c255d 2023-08-04 jrmu ;; ;; (let ((x 5))
1035 665c255d 2023-08-04 jrmu ;; ;; (define y x)
1036 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
1037 665c255d 2023-08-04 jrmu ;; ;; (* y x)))
1040 665c255d 2023-08-04 jrmu ;; ;; (test-eval
1041 665c255d 2023-08-04 jrmu ;; ;; '(let ((y -1) (x 3))
1042 665c255d 2023-08-04 jrmu ;; ;; (let ((y 0.5) (x 5))
1043 665c255d 2023-08-04 jrmu ;; ;; (define a x)
1044 665c255d 2023-08-04 jrmu ;; ;; (define b y)
1045 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
1046 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! y)
1047 665c255d 2023-08-04 jrmu ;; ;; (* a b x y)))
1048 665c255d 2023-08-04 jrmu ;; ;; (* 5 3 -1 0.5))
1050 665c255d 2023-08-04 jrmu ;; ;; (test-eval
1051 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 3) (y 4))
1052 665c255d 2023-08-04 jrmu ;; ;; (let ((x 5))
1053 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
1054 665c255d 2023-08-04 jrmu ;; ;; (+ x 4)))
1057 665c255d 2023-08-04 jrmu ;; ;; (test-eval
1058 665c255d 2023-08-04 jrmu ;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
1059 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! b)
1060 665c255d 2023-08-04 jrmu ;; ;; (+ a c d))
1061 665c255d 2023-08-04 jrmu ;; ;; (+ 1 3 4))
1063 665c255d 2023-08-04 jrmu ;; ;; (test-eval
1064 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 4) (y 5))
1065 665c255d 2023-08-04 jrmu ;; ;; (let ((a 1) (b 2) (c 3))
1066 665c255d 2023-08-04 jrmu ;; ;; (let ((x (+ a b)) (y (+ c a)))
1067 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
1068 665c255d 2023-08-04 jrmu ;; ;; (let ((a x) (b (+ x y)))
1069 665c255d 2023-08-04 jrmu ;; ;; (define z b)
1070 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! b)
1071 665c255d 2023-08-04 jrmu ;; ;; (* (+ a z)
1072 665c255d 2023-08-04 jrmu ;; ;; (+ a b y))))))
1073 665c255d 2023-08-04 jrmu ;; ;; (* (+ 4 8)
1074 665c255d 2023-08-04 jrmu ;; ;; (+ 4 2 4)))
1076 665c255d 2023-08-04 jrmu ;; ;; x 3 -- y 4
1077 665c255d 2023-08-04 jrmu ;; ;; x 4 -- y 4
1078 665c255d 2023-08-04 jrmu ;; ;; a 4 -- b 4
1079 665c255d 2023-08-04 jrmu ;; ;; a 4 -- b 2
1081 665c255d 2023-08-04 jrmu ;; ;; scan-out-defines
1084 665c255d 2023-08-04 jrmu ;; '(define (f x)
1085 665c255d 2023-08-04 jrmu ;; (define (even? n)
1086 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1088 665c255d 2023-08-04 jrmu ;; (odd? (- n 1))))
1089 665c255d 2023-08-04 jrmu ;; (define (odd? n)
1090 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1092 665c255d 2023-08-04 jrmu ;; (even? (- n 1))))
1093 665c255d 2023-08-04 jrmu ;; (even? x)))
1094 665c255d 2023-08-04 jrmu ;; (test-eval '(f 5) false)
1095 665c255d 2023-08-04 jrmu ;; (test-eval '(f 10) true)
1097 665c255d 2023-08-04 jrmu ;; ;; (geval
1098 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 5))
1099 665c255d 2023-08-04 jrmu ;; ;; (define y x)
1100 665c255d 2023-08-04 jrmu ;; ;; (define x 3)
1101 665c255d 2023-08-04 jrmu ;; ;; (+ x y)))
1102 665c255d 2023-08-04 jrmu ;; ;; signal an error because x is undefined if variables are scanned out
1104 665c255d 2023-08-04 jrmu ;; ;; letrec
1107 665c255d 2023-08-04 jrmu ;; '(define (f x)
1108 665c255d 2023-08-04 jrmu ;; (letrec ((even?
1109 665c255d 2023-08-04 jrmu ;; (lambda (n)
1110 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1112 665c255d 2023-08-04 jrmu ;; (odd? (- n 1)))))
1114 665c255d 2023-08-04 jrmu ;; (lambda (n)
1115 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1117 665c255d 2023-08-04 jrmu ;; (even? (- n 1))))))
1118 665c255d 2023-08-04 jrmu ;; (even? x))))
1119 665c255d 2023-08-04 jrmu ;; (test-eval '(f 11) false)
1120 665c255d 2023-08-04 jrmu ;; (test-eval '(f 16) true)
1122 665c255d 2023-08-04 jrmu ;; (test-eval
1123 665c255d 2023-08-04 jrmu ;; '(letrec ((fact
1124 665c255d 2023-08-04 jrmu ;; (lambda (n)
1125 665c255d 2023-08-04 jrmu ;; (if (= n 1)
1127 665c255d 2023-08-04 jrmu ;; (* n (fact (- n 1)))))))
1128 665c255d 2023-08-04 jrmu ;; (fact 10))
1129 665c255d 2023-08-04 jrmu ;; 3628800)
1132 665c255d 2023-08-04 jrmu (geval '(define (require p) (if (not p) (amb))))
1134 665c255d 2023-08-04 jrmu ;; (test-eval '(amb 1 2 3) 1)
1135 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 2)
1136 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 3)
1137 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again "No alternatives")
1138 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again "No current problem")
1139 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again "No current problem")
1140 665c255d 2023-08-04 jrmu ;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
1142 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 2)
1143 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 'a)
1144 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 'b)
1145 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again "No alternatives")
1146 665c255d 2023-08-04 jrmu ;; (test-eval '(require false) "No alternatives")
1147 665c255d 2023-08-04 jrmu ;; (test-eval '(require true) false)
1151 665c255d 2023-08-04 jrmu '(define (an-integer-between low high)
1152 665c255d 2023-08-04 jrmu (require (<= low high))
1153 665c255d 2023-08-04 jrmu (amb low (an-integer-between (+ low 1) high))))
1156 665c255d 2023-08-04 jrmu '(define (a-pythagorean-triple-between low high)
1157 665c255d 2023-08-04 jrmu (let ((i (an-integer-between low high)))
1158 665c255d 2023-08-04 jrmu (let ((j (an-integer-between i high)))
1159 665c255d 2023-08-04 jrmu (let ((k (an-integer-between j high)))
1160 665c255d 2023-08-04 jrmu (require (= (+ (* i i) (* j j)) (* k k)))
1161 665c255d 2023-08-04 jrmu (list i j k))))))
1163 665c255d 2023-08-04 jrmu ;; (test-eval
1164 665c255d 2023-08-04 jrmu ;; '(a-pythagorean-triple-between 1 20)
1165 665c255d 2023-08-04 jrmu ;; '(3 4 5))
1166 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(5 12 13))
1167 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(6 8 10))
1168 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(8 15 17))
1169 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(9 12 15))
1172 665c255d 2023-08-04 jrmu '(define (an-integer-starting-from low)
1173 665c255d 2023-08-04 jrmu (amb low (an-integer-starting-from (+ low 1)))))
1176 665c255d 2023-08-04 jrmu '(define (pythagorean-triples-starting-from low)
1177 665c255d 2023-08-04 jrmu (let* ((k (an-integer-starting-from low))
1178 665c255d 2023-08-04 jrmu (i (an-integer-between low k))
1179 665c255d 2023-08-04 jrmu (j (an-integer-between i k)))
1180 665c255d 2023-08-04 jrmu (require (= (+ (* i i) (* j j)) (* k k)))
1181 665c255d 2023-08-04 jrmu (list i j k))))
1183 665c255d 2023-08-04 jrmu ;; (test-eval '(pythagorean-triples-starting-from 1)
1184 665c255d 2023-08-04 jrmu ;; '(3 4 5))
1185 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(6 8 10))
1186 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(5 12 13))
1187 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(9 12 15))
1188 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(8 15 17))
1191 665c255d 2023-08-04 jrmu '(define (next-triplet trp)
1192 665c255d 2023-08-04 jrmu (let ((i (car trp))
1193 665c255d 2023-08-04 jrmu (j (cadr trp))
1194 665c255d 2023-08-04 jrmu (k (caddr trp)))
1195 665c255d 2023-08-04 jrmu (cond ((= i j k) (list 1 1 (+ k 1)))
1196 665c255d 2023-08-04 jrmu ((= j k) (list (+ i 1) (+ i 1) k))
1197 665c255d 2023-08-04 jrmu (else (list i (+ j 1) k))))))
1199 665c255d 2023-08-04 jrmu '(define (triplet-starting-from trp)
1200 665c255d 2023-08-04 jrmu (amb trp (triplet-starting-from (next-triplet trp)))))
1202 665c255d 2023-08-04 jrmu '(define (pythagorean-triples-starting-from low)
1203 665c255d 2023-08-04 jrmu (let* ((triplet (triplet-starting-from (list low low low)))
1204 665c255d 2023-08-04 jrmu (i (car triplet))
1205 665c255d 2023-08-04 jrmu (j (cadr triplet))
1206 665c255d 2023-08-04 jrmu (k (caddr triplet)))
1207 665c255d 2023-08-04 jrmu (require (= (+ (* i i) (* j j)) (* k k)))
1208 665c255d 2023-08-04 jrmu (list i j k))))
1210 665c255d 2023-08-04 jrmu '(define (distinct? items)
1211 665c255d 2023-08-04 jrmu (cond ((null? items) true)
1212 665c255d 2023-08-04 jrmu ((null? (cdr items)) true)
1213 665c255d 2023-08-04 jrmu ((member (car items) (cdr items)) false)
1214 665c255d 2023-08-04 jrmu (else (distinct? (cdr items))))))
1217 665c255d 2023-08-04 jrmu '(define (an-element-of items)
1218 665c255d 2023-08-04 jrmu (require (not (null? items)))
1219 665c255d 2023-08-04 jrmu (amb (car items) (an-element-of (cdr items)))))
1222 665c255d 2023-08-04 jrmu '(define count 0))
1223 665c255d 2023-08-04 jrmu (test-eval
1224 665c255d 2023-08-04 jrmu '(let ((x (an-element-of '(a b c)))
1225 665c255d 2023-08-04 jrmu (y (an-element-of '(a b c))))
1226 665c255d 2023-08-04 jrmu (permanent-set! count (+ count 1))
1227 665c255d 2023-08-04 jrmu (require (not (eq? x y)))
1228 665c255d 2023-08-04 jrmu (list x y count))
1230 665c255d 2023-08-04 jrmu (test-eval 'try-again '(a c 3))
1232 665c255d 2023-08-04 jrmu (test-eval
1233 665c255d 2023-08-04 jrmu '(if-fail (let ((x (an-element-of '(1 3 5))))
1234 665c255d 2023-08-04 jrmu (require (even? x))
1238 665c255d 2023-08-04 jrmu (test-eval 'try-again "No alternatives")
1240 665c255d 2023-08-04 jrmu (test-eval
1241 665c255d 2023-08-04 jrmu '(if-fail (let ((x (an-element-of '(1 3 5 8))))
1242 665c255d 2023-08-04 jrmu (require (even? x))
1246 665c255d 2023-08-04 jrmu (test-eval 'try-again "all-odd")
1247 665c255d 2023-08-04 jrmu (test-eval 'try-again "No alternatives")
1249 665c255d 2023-08-04 jrmu ;; Exercise 4.53. With permanent-set! as described in exercise 4.51 and if-fail as in exercise 4.52, what will be the result of evaluating
1252 665c255d 2023-08-04 jrmu '(define (prime? n)
1253 665c255d 2023-08-04 jrmu (= n (smallest-divisor n))))
1255 665c255d 2023-08-04 jrmu '(define (smallest-divisor n)
1256 665c255d 2023-08-04 jrmu (find-divisor n 2)))
1258 665c255d 2023-08-04 jrmu '(define (square x) (* x x)))
1260 665c255d 2023-08-04 jrmu '(define (find-divisor n test-divisor)
1261 665c255d 2023-08-04 jrmu (cond ((> (square test-divisor) n) n)
1262 665c255d 2023-08-04 jrmu ((divides? test-divisor n) test-divisor)
1263 665c255d 2023-08-04 jrmu (else (find-divisor n (+ test-divisor 1))))))
1265 665c255d 2023-08-04 jrmu '(define (divides? a b)
1266 665c255d 2023-08-04 jrmu (= (remainder b a) 0)))
1270 665c255d 2023-08-04 jrmu '(define (prime-sum-pair list1 list2)
1271 665c255d 2023-08-04 jrmu (let ((a (an-element-of list1))
1272 665c255d 2023-08-04 jrmu (b (an-element-of list2)))
1273 665c255d 2023-08-04 jrmu (require (prime? (+ a b)))
1274 665c255d 2023-08-04 jrmu (list a b))))
1276 665c255d 2023-08-04 jrmu (test-eval
1277 665c255d 2023-08-04 jrmu '(let ((pairs '()))
1279 665c255d 2023-08-04 jrmu (let ((p (prime-sum-pair '(1 3 5 8)
1280 665c255d 2023-08-04 jrmu '(20 35 110))))
1281 665c255d 2023-08-04 jrmu (permanent-set! pairs (cons p pairs))
1284 665c255d 2023-08-04 jrmu '((8 35) (3 110) (3 20)))
