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 ((definition? exp) (analyze-definition exp))
10 665c255d 2023-08-04 jrmu ((if? exp) (analyze-if exp))
11 665c255d 2023-08-04 jrmu ((and? exp) (analyze (and->if exp)))
12 665c255d 2023-08-04 jrmu ((or? exp) (analyze (or->if exp)))
13 665c255d 2023-08-04 jrmu ((not? exp) (analyze (not->if exp)))
14 665c255d 2023-08-04 jrmu ((lambda? exp) (analyze-lambda exp))
15 665c255d 2023-08-04 jrmu ((let? exp) (analyze (let->combination exp)))
16 665c255d 2023-08-04 jrmu ((let*? exp) (analyze (let*->nested-lets exp)))
17 665c255d 2023-08-04 jrmu ((named-let? exp) (analyze (named-let->combination exp)))
18 665c255d 2023-08-04 jrmu ((letrec? exp) (analyze (letrec->let exp)))
19 665c255d 2023-08-04 jrmu ((do? exp) (analyze (do->combination exp)))
20 665c255d 2023-08-04 jrmu ((begin? exp) (analyze-sequence (begin-actions exp)))
21 665c255d 2023-08-04 jrmu ((cond? exp) (analyze (cond->if exp)))
22 665c255d 2023-08-04 jrmu ((amb? exp) (analyze-amb exp))
23 665c255d 2023-08-04 jrmu ((application? exp) (analyze-application exp))
25 665c255d 2023-08-04 jrmu (error "Unknown expression type -- ANALYZE" exp))))
28 665c255d 2023-08-04 jrmu ;; analyzing procedures
29 665c255d 2023-08-04 jrmu (define (analyze-self-evaluating exp)
30 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
31 665c255d 2023-08-04 jrmu (succeed exp fail)))
32 665c255d 2023-08-04 jrmu (define (analyze-quoted exp)
33 665c255d 2023-08-04 jrmu (let ((qval (text-of-quotation exp)))
34 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
35 665c255d 2023-08-04 jrmu (succeed qval fail))))
36 665c255d 2023-08-04 jrmu (define (analyze-variable exp)
37 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
38 665c255d 2023-08-04 jrmu (succeed (lookup-variable-value exp env)
40 665c255d 2023-08-04 jrmu (define (analyze-lambda exp)
41 665c255d 2023-08-04 jrmu (let ((vars (lambda-parameters exp))
42 665c255d 2023-08-04 jrmu ;; (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
43 665c255d 2023-08-04 jrmu (bproc (analyze-sequence (lambda-body exp))))
44 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
45 665c255d 2023-08-04 jrmu (succeed (make-procedure vars bproc env)
47 665c255d 2023-08-04 jrmu (define (analyze-if exp)
48 665c255d 2023-08-04 jrmu (let ((pproc (analyze (if-predicate exp)))
49 665c255d 2023-08-04 jrmu (cproc (analyze (if-consequent exp)))
50 665c255d 2023-08-04 jrmu (aproc (analyze (if-alternative exp))))
51 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
53 665c255d 2023-08-04 jrmu ;; success continuation for evaluating the predicate
54 665c255d 2023-08-04 jrmu ;; to obtain pred-value
55 665c255d 2023-08-04 jrmu (lambda (pred-value fail2)
56 665c255d 2023-08-04 jrmu (if (true? pred-value)
57 665c255d 2023-08-04 jrmu (cproc env succeed fail2)
58 665c255d 2023-08-04 jrmu (aproc env succeed fail2)))
59 665c255d 2023-08-04 jrmu ;; failure continuation for evaluating the predicate
61 665c255d 2023-08-04 jrmu (define (analyze-sequence exps)
62 665c255d 2023-08-04 jrmu (define (sequentially a b)
63 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
65 665c255d 2023-08-04 jrmu ;; success continuation for calling a
66 665c255d 2023-08-04 jrmu (lambda (a-value fail2)
67 665c255d 2023-08-04 jrmu (b env succeed fail2))
68 665c255d 2023-08-04 jrmu ;; failure continuation for calling a
70 665c255d 2023-08-04 jrmu (define (loop first-proc rest-procs)
71 665c255d 2023-08-04 jrmu (if (null? rest-procs)
73 665c255d 2023-08-04 jrmu (loop (sequentially first-proc (car rest-procs))
74 665c255d 2023-08-04 jrmu (cdr rest-procs))))
75 665c255d 2023-08-04 jrmu (let ((procs (map analyze exps)))
76 665c255d 2023-08-04 jrmu (if (null? procs)
77 665c255d 2023-08-04 jrmu (error "Empty sequence -- ANALYZE"))
78 665c255d 2023-08-04 jrmu (loop (car procs) (cdr procs))))
79 665c255d 2023-08-04 jrmu (define (analyze-definition exp)
80 665c255d 2023-08-04 jrmu (let ((var (definition-variable exp))
81 665c255d 2023-08-04 jrmu (vproc (analyze (definition-value exp))))
82 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
84 665c255d 2023-08-04 jrmu (lambda (val fail2)
85 665c255d 2023-08-04 jrmu (define-variable! var val env)
86 665c255d 2023-08-04 jrmu (succeed 'ok fail2))
88 665c255d 2023-08-04 jrmu (define (analyze-assignment exp)
89 665c255d 2023-08-04 jrmu (let ((var (assignment-variable exp))
90 665c255d 2023-08-04 jrmu (vproc (analyze (assignment-value exp))))
91 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
93 665c255d 2023-08-04 jrmu (lambda (val fail2) ; *1*
94 665c255d 2023-08-04 jrmu (let ((old-value
95 665c255d 2023-08-04 jrmu (lookup-variable-value var env)))
96 665c255d 2023-08-04 jrmu (set-variable-value! var val env)
97 665c255d 2023-08-04 jrmu (succeed 'ok
98 665c255d 2023-08-04 jrmu (lambda () ; *2*
99 665c255d 2023-08-04 jrmu (set-variable-value! var
102 665c255d 2023-08-04 jrmu (fail2)))))
105 665c255d 2023-08-04 jrmu (define (analyze-application exp)
106 665c255d 2023-08-04 jrmu (let ((fproc (analyze (operator exp)))
107 665c255d 2023-08-04 jrmu (aprocs (map analyze (operands exp))))
108 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
110 665c255d 2023-08-04 jrmu (lambda (proc fail2)
111 665c255d 2023-08-04 jrmu (get-args aprocs
113 665c255d 2023-08-04 jrmu (lambda (args fail3)
114 665c255d 2023-08-04 jrmu (execute-application
115 665c255d 2023-08-04 jrmu proc args succeed fail3))
118 665c255d 2023-08-04 jrmu (define (get-args aprocs env succeed fail)
119 665c255d 2023-08-04 jrmu (if (null? aprocs)
120 665c255d 2023-08-04 jrmu (succeed '() fail)
121 665c255d 2023-08-04 jrmu ((car aprocs) env
122 665c255d 2023-08-04 jrmu ;; success continuation for this aproc
123 665c255d 2023-08-04 jrmu (lambda (arg fail2)
124 665c255d 2023-08-04 jrmu (get-args (cdr aprocs)
126 665c255d 2023-08-04 jrmu ;; success continuation for recursive
127 665c255d 2023-08-04 jrmu ;; call to get-args
128 665c255d 2023-08-04 jrmu (lambda (args fail3)
129 665c255d 2023-08-04 jrmu (succeed (cons arg args)
134 665c255d 2023-08-04 jrmu (define (analyze-amb exp)
135 665c255d 2023-08-04 jrmu (let ((cprocs (map analyze (amb-choices exp))))
136 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
137 665c255d 2023-08-04 jrmu (define (try-next choices)
138 665c255d 2023-08-04 jrmu (if (null? choices)
140 665c255d 2023-08-04 jrmu ((car choices) env
143 665c255d 2023-08-04 jrmu (try-next (cdr choices))))))
144 665c255d 2023-08-04 jrmu (try-next cprocs))))
151 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
152 665c255d 2023-08-04 jrmu (if (pair? exp)
153 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
157 665c255d 2023-08-04 jrmu (define (amb? exp) (tagged-list? exp 'amb))
158 665c255d 2023-08-04 jrmu (define (amb-choices exp) (cdr exp))
160 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
161 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
162 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
163 665c255d 2023-08-04 jrmu ((string? exp) true)
164 665c255d 2023-08-04 jrmu (else false)))
165 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
166 665c255d 2023-08-04 jrmu (define (quoted? exp)
167 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
168 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
170 665c255d 2023-08-04 jrmu ;; assignment/definition
171 665c255d 2023-08-04 jrmu (define (assignment? exp)
172 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
173 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
174 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
175 665c255d 2023-08-04 jrmu (define (make-assignment var val)
176 665c255d 2023-08-04 jrmu (list 'set! var val))
177 665c255d 2023-08-04 jrmu (define (definition? exp)
178 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
179 665c255d 2023-08-04 jrmu (define (definition-variable exp)
180 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
182 665c255d 2023-08-04 jrmu (caadr exp)))
183 665c255d 2023-08-04 jrmu (define (definition-value exp)
184 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
185 665c255d 2023-08-04 jrmu (caddr exp)
186 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
187 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
188 665c255d 2023-08-04 jrmu (define (make-definition var val)
189 665c255d 2023-08-04 jrmu `(define ,var ,val))
191 665c255d 2023-08-04 jrmu ;; if/and/or/not
192 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
193 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
194 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
195 665c255d 2023-08-04 jrmu (define (if-alternative exp)
196 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
197 665c255d 2023-08-04 jrmu (cadddr exp)
199 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
200 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
202 665c255d 2023-08-04 jrmu (define (and? exp)
203 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
204 665c255d 2023-08-04 jrmu (define (and-clauses exp)
206 665c255d 2023-08-04 jrmu (define (or? exp)
207 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
208 665c255d 2023-08-04 jrmu (define (or-clauses exp)
210 665c255d 2023-08-04 jrmu (define (and->if exp)
211 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
212 665c255d 2023-08-04 jrmu (cond ((null? clauses) 'true)
213 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (car clauses))
214 665c255d 2023-08-04 jrmu (else (make-if (car clauses)
215 665c255d 2023-08-04 jrmu (expand-clauses (cdr clauses))
217 665c255d 2023-08-04 jrmu (expand-clauses (and-clauses exp)))
218 665c255d 2023-08-04 jrmu (define (or->if exp)
219 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
220 665c255d 2023-08-04 jrmu (if (null? clauses)
222 665c255d 2023-08-04 jrmu (make-if (car clauses)
223 665c255d 2023-08-04 jrmu (car clauses)
224 665c255d 2023-08-04 jrmu (expand-clauses (cdr clauses)))))
225 665c255d 2023-08-04 jrmu (expand-clauses (or-clauses exp)))
226 665c255d 2023-08-04 jrmu (define (not? exp)
227 665c255d 2023-08-04 jrmu (tagged-list? exp 'not))
228 665c255d 2023-08-04 jrmu (define (not->if exp)
229 665c255d 2023-08-04 jrmu `(if ,(cadr exp) false true))
231 665c255d 2023-08-04 jrmu ;; lambda/let/let*/letrec
232 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
233 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
234 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
235 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
236 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
238 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
240 665c255d 2023-08-04 jrmu (cons (map list vars vals)
242 665c255d 2023-08-04 jrmu (define (let? exp)
243 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
244 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
245 665c255d 2023-08-04 jrmu (define (let-vars exp)
246 665c255d 2023-08-04 jrmu (map car (cadr exp)))
247 665c255d 2023-08-04 jrmu (define (let-vals exp)
248 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
249 665c255d 2023-08-04 jrmu (define (let-body exp)
250 665c255d 2023-08-04 jrmu (cddr exp))
251 665c255d 2023-08-04 jrmu (define (let->combination exp)
252 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
253 665c255d 2023-08-04 jrmu (let-vals exp)))
254 665c255d 2023-08-04 jrmu (define (named-let? exp)
255 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
256 665c255d 2023-08-04 jrmu (symbol? (cadr exp))))
257 665c255d 2023-08-04 jrmu (define (named-let-name exp)
258 665c255d 2023-08-04 jrmu (cadr exp))
259 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
260 665c255d 2023-08-04 jrmu (map car (caddr exp)))
261 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
262 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
263 665c255d 2023-08-04 jrmu (define (named-let-body exp)
264 665c255d 2023-08-04 jrmu (cdddr exp))
265 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
266 665c255d 2023-08-04 jrmu (sequence->exp
267 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
268 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
269 665c255d 2023-08-04 jrmu (named-let-body exp)))
270 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
271 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
272 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
275 665c255d 2023-08-04 jrmu (cons (map list vars vals)
278 665c255d 2023-08-04 jrmu (define (letrec? exp)
279 665c255d 2023-08-04 jrmu (tagged-list? exp 'letrec))
281 665c255d 2023-08-04 jrmu (define (letrec-vars exp)
282 665c255d 2023-08-04 jrmu (map car (cadr exp)))
283 665c255d 2023-08-04 jrmu (define (letrec-vals exp)
284 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
285 665c255d 2023-08-04 jrmu (define (letrec-body exp)
286 665c255d 2023-08-04 jrmu (cddr exp))
287 665c255d 2023-08-04 jrmu (define (letrec->let exp)
288 665c255d 2023-08-04 jrmu (let* ((vars (letrec-vars exp))
289 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
291 665c255d 2023-08-04 jrmu (vals (letrec-vals exp))
292 665c255d 2023-08-04 jrmu (assignments (map (lambda (var val)
293 665c255d 2023-08-04 jrmu (make-assignment var val))
296 665c255d 2023-08-04 jrmu (body (letrec-body exp)))
297 665c255d 2023-08-04 jrmu (make-let vars
298 665c255d 2023-08-04 jrmu unassigneds
299 665c255d 2023-08-04 jrmu (append assignments body))))
301 665c255d 2023-08-04 jrmu (define (make-application op args)
302 665c255d 2023-08-04 jrmu (cons op args))
304 665c255d 2023-08-04 jrmu (define (let*? exp)
305 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
306 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
307 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
308 665c255d 2023-08-04 jrmu (define let*-body let-body)
309 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
310 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
311 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
312 665c255d 2023-08-04 jrmu (make-let (list (car vars))
313 665c255d 2023-08-04 jrmu (list (car vals))
314 665c255d 2023-08-04 jrmu (let*-body exp))
315 665c255d 2023-08-04 jrmu (make-let (list (car vars))
316 665c255d 2023-08-04 jrmu (list (car vals))
317 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
318 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
319 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
320 665c255d 2023-08-04 jrmu (if (null? vars)
321 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
322 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
325 665c255d 2023-08-04 jrmu (define (do? exp)
326 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
327 665c255d 2023-08-04 jrmu (define (do-vars exp)
328 665c255d 2023-08-04 jrmu (map car (cadr exp)))
329 665c255d 2023-08-04 jrmu (define (do-inits exp)
330 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
331 665c255d 2023-08-04 jrmu (define (do-steps exp)
332 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
333 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
334 665c255d 2023-08-04 jrmu (car var-init-step)
335 665c255d 2023-08-04 jrmu (caddr var-init-step)))
336 665c255d 2023-08-04 jrmu (cadr exp)))
337 665c255d 2023-08-04 jrmu (define (do-test exp)
338 665c255d 2023-08-04 jrmu (caaddr exp))
339 665c255d 2023-08-04 jrmu (define (do-expressions exp)
340 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
341 665c255d 2023-08-04 jrmu (caddr exp)
342 665c255d 2023-08-04 jrmu (cdaddr exp)))
343 665c255d 2023-08-04 jrmu (define (do-commands exp)
344 665c255d 2023-08-04 jrmu (cdddr exp))
345 665c255d 2023-08-04 jrmu (define (do->combination exp)
346 665c255d 2023-08-04 jrmu (make-named-let
348 665c255d 2023-08-04 jrmu (do-vars exp)
349 665c255d 2023-08-04 jrmu (do-inits exp)
352 665c255d 2023-08-04 jrmu (do-test exp)
353 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
354 665c255d 2023-08-04 jrmu (sequence->exp
355 665c255d 2023-08-04 jrmu (append (do-commands exp)
356 665c255d 2023-08-04 jrmu (list (make-application
358 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
361 665c255d 2023-08-04 jrmu ;; begin/sequence
362 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
363 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
364 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
365 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
366 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
367 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
368 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
369 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
370 665c255d 2023-08-04 jrmu (else (make-begin seq))))
371 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
373 665c255d 2023-08-04 jrmu ;; application
374 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
375 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
376 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
377 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
378 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
379 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
382 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
383 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
384 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
385 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
386 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
387 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
388 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
389 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
390 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
391 665c255d 2023-08-04 jrmu (caddr clause))
392 665c255d 2023-08-04 jrmu (define (cond->if exp)
393 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
394 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
395 665c255d 2023-08-04 jrmu (if (null? clauses)
396 665c255d 2023-08-04 jrmu 'false ; no else clause
397 665c255d 2023-08-04 jrmu (let ((first (car clauses))
398 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
399 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
400 665c255d 2023-08-04 jrmu (if (null? rest)
401 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
402 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
404 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
405 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
406 665c255d 2023-08-04 jrmu (make-application
407 665c255d 2023-08-04 jrmu (cond-extended-proc first)
408 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
409 665c255d 2023-08-04 jrmu (expand-clauses rest))
410 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
411 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
412 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
413 665c255d 2023-08-04 jrmu (define (true? x)
414 665c255d 2023-08-04 jrmu (not (eq? x false)))
415 665c255d 2023-08-04 jrmu (define (false? x)
416 665c255d 2023-08-04 jrmu (eq? x false))
418 665c255d 2023-08-04 jrmu ;; procedure
419 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
420 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
421 665c255d 2023-08-04 jrmu (define (scan-out-defines body)
422 665c255d 2023-08-04 jrmu (let* ((definitions (filter definition? body))
423 665c255d 2023-08-04 jrmu (vars (map definition-variable definitions))
424 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
426 665c255d 2023-08-04 jrmu (vals (map definition-value definitions))
427 665c255d 2023-08-04 jrmu (assignments
428 665c255d 2023-08-04 jrmu (map (lambda (var val)
429 665c255d 2023-08-04 jrmu (make-assignment var val))
430 665c255d 2023-08-04 jrmu vars vals))
431 665c255d 2023-08-04 jrmu (exps (remove definition? body)))
432 665c255d 2023-08-04 jrmu (if (null? definitions)
435 665c255d 2023-08-04 jrmu (make-let vars
436 665c255d 2023-08-04 jrmu unassigneds
437 665c255d 2023-08-04 jrmu (append assignments exps))))))
438 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
439 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
440 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
441 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
442 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
444 665c255d 2023-08-04 jrmu ;; environment
445 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
446 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
447 665c255d 2023-08-04 jrmu (define the-empty-environment '())
448 665c255d 2023-08-04 jrmu (define (make-frame variables values)
449 665c255d 2023-08-04 jrmu (cons variables values))
450 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
451 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
452 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
453 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
454 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
455 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
456 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
457 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
458 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
459 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
460 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
461 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
462 665c255d 2023-08-04 jrmu (define (env-loop env)
463 665c255d 2023-08-04 jrmu (define (scan vars vals)
464 665c255d 2023-08-04 jrmu (cond ((null? vars)
465 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
466 665c255d 2023-08-04 jrmu ((eq? var (car vars))
467 665c255d 2023-08-04 jrmu (let ((val (car vals)))
468 665c255d 2023-08-04 jrmu (if (eq? val '*unassigned*)
469 665c255d 2023-08-04 jrmu (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
471 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
472 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
473 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
474 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
475 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
476 665c255d 2023-08-04 jrmu (frame-values frame)))))
477 665c255d 2023-08-04 jrmu (env-loop env))
478 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
479 665c255d 2023-08-04 jrmu (define (env-loop env)
480 665c255d 2023-08-04 jrmu (define (scan vars vals)
481 665c255d 2023-08-04 jrmu (cond ((null? vars)
482 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
483 665c255d 2023-08-04 jrmu ((eq? var (car vars))
484 665c255d 2023-08-04 jrmu (set-car! vals val))
485 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
486 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
487 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
488 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
489 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
490 665c255d 2023-08-04 jrmu (frame-values frame)))))
491 665c255d 2023-08-04 jrmu (env-loop env))
492 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
493 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
494 665c255d 2023-08-04 jrmu (define (scan vars vals)
495 665c255d 2023-08-04 jrmu (cond ((null? vars)
496 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
497 665c255d 2023-08-04 jrmu ((eq? var (car vars))
498 665c255d 2023-08-04 jrmu (set-car! vals val))
499 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
500 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
501 665c255d 2023-08-04 jrmu (frame-values frame))))
503 665c255d 2023-08-04 jrmu ;; (define (remove-binding-from-frame! var frame)
504 665c255d 2023-08-04 jrmu ;; (define (scan vars vals)
505 665c255d 2023-08-04 jrmu ;; (cond ((null? (cdr vars))
506 665c255d 2023-08-04 jrmu ;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
507 665c255d 2023-08-04 jrmu ;; ((eq? var (cadr vars))
508 665c255d 2023-08-04 jrmu ;; (set-cdr! vars (cddr vars))
509 665c255d 2023-08-04 jrmu ;; (set-cdr! vals (cddr vals)))
510 665c255d 2023-08-04 jrmu ;; (else (scan (cdr vars) (cdr vals)))))
511 665c255d 2023-08-04 jrmu ;; (let ((vars (frame-variables frame))
512 665c255d 2023-08-04 jrmu ;; (vals (frame-values frame)))
513 665c255d 2023-08-04 jrmu ;; (if (eq? var (car vars))
514 665c255d 2023-08-04 jrmu ;; (begin (set-car! frame (cdr vars))
515 665c255d 2023-08-04 jrmu ;; (set-cdr! frame (cdr vals)))
516 665c255d 2023-08-04 jrmu ;; (scan vars vals))))
518 665c255d 2023-08-04 jrmu ;; primitives
519 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
520 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
521 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
522 665c255d 2023-08-04 jrmu (define primitive-procedures
523 665c255d 2023-08-04 jrmu (list (list 'car car)
524 665c255d 2023-08-04 jrmu (list 'cdr cdr)
525 665c255d 2023-08-04 jrmu (list 'caar caar)
526 665c255d 2023-08-04 jrmu (list 'cadr cadr)
527 665c255d 2023-08-04 jrmu (list 'cddr cddr)
528 665c255d 2023-08-04 jrmu (list 'caddr caddr)
529 665c255d 2023-08-04 jrmu (list 'cdddr cdddr)
530 665c255d 2023-08-04 jrmu (list 'cons cons)
531 665c255d 2023-08-04 jrmu (list 'list list)
532 665c255d 2023-08-04 jrmu (list 'null? null?)
533 665c255d 2023-08-04 jrmu (list '* *)
534 665c255d 2023-08-04 jrmu (list '/ /)
535 665c255d 2023-08-04 jrmu (list '+ +)
536 665c255d 2023-08-04 jrmu (list '- -)
537 665c255d 2023-08-04 jrmu (list '= =)
538 665c255d 2023-08-04 jrmu (list '< <)
539 665c255d 2023-08-04 jrmu (list '> >)
540 665c255d 2023-08-04 jrmu (list '<= <=)
541 665c255d 2023-08-04 jrmu (list '>= >=)
542 665c255d 2023-08-04 jrmu (list 'abs abs)
543 665c255d 2023-08-04 jrmu (list 'remainder remainder)
544 665c255d 2023-08-04 jrmu (list 'eq? eq?)
545 665c255d 2023-08-04 jrmu (list 'equal? equal?)
546 665c255d 2023-08-04 jrmu (list 'member member)
547 665c255d 2023-08-04 jrmu (list 'display display)))
548 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
550 665c255d 2023-08-04 jrmu primitive-procedures))
551 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
552 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
553 665c255d 2023-08-04 jrmu primitive-procedures))
554 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
556 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
558 665c255d 2023-08-04 jrmu ;; execute application
560 665c255d 2023-08-04 jrmu (define (execute-application proc args succeed fail)
561 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? proc)
562 665c255d 2023-08-04 jrmu (succeed (apply-primitive-procedure proc args)
564 665c255d 2023-08-04 jrmu ((compound-procedure? proc)
565 665c255d 2023-08-04 jrmu ((procedure-body proc)
566 665c255d 2023-08-04 jrmu (extend-environment (procedure-parameters proc)
568 665c255d 2023-08-04 jrmu (procedure-environment proc))
573 665c255d 2023-08-04 jrmu "Unknown procedure type -- EXECUTE-APPLICATION"
577 665c255d 2023-08-04 jrmu ;; driver-loop
578 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
579 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
580 665c255d 2023-08-04 jrmu (define (announce-output string)
581 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
582 665c255d 2023-08-04 jrmu (define (user-print object)
583 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
584 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
585 665c255d 2023-08-04 jrmu (procedure-parameters object)
586 665c255d 2023-08-04 jrmu (procedure-body object)
587 665c255d 2023-08-04 jrmu '<procedure-env>))
588 665c255d 2023-08-04 jrmu (display object)))
589 665c255d 2023-08-04 jrmu (define (setup-environment)
590 665c255d 2023-08-04 jrmu (let ((initial-env
591 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
592 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
593 665c255d 2023-08-04 jrmu the-empty-environment)))
594 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
595 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
596 665c255d 2023-08-04 jrmu initial-env))
597 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
599 665c255d 2023-08-04 jrmu (define input-prompt ";;; Amb-Eval input:")
600 665c255d 2023-08-04 jrmu (define output-prompt ";;; Amb-Eval value:")
601 665c255d 2023-08-04 jrmu (define (driver-loop)
602 665c255d 2023-08-04 jrmu (define (internal-loop try-again)
603 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
604 665c255d 2023-08-04 jrmu (let ((input (read)))
605 665c255d 2023-08-04 jrmu (if (eq? input 'try-again)
606 665c255d 2023-08-04 jrmu (try-again)
609 665c255d 2023-08-04 jrmu (display ";;; Starting a new problem ")
610 665c255d 2023-08-04 jrmu (ambeval input
611 665c255d 2023-08-04 jrmu the-global-environment
612 665c255d 2023-08-04 jrmu ;; ambeval success
613 665c255d 2023-08-04 jrmu (lambda (val next-alternative)
614 665c255d 2023-08-04 jrmu (announce-output output-prompt)
615 665c255d 2023-08-04 jrmu (user-print val)
616 665c255d 2023-08-04 jrmu (internal-loop next-alternative))
617 665c255d 2023-08-04 jrmu ;; ambeval failure
619 665c255d 2023-08-04 jrmu (announce-output
620 665c255d 2023-08-04 jrmu ";;; There are no more values of")
621 665c255d 2023-08-04 jrmu (user-print input)
622 665c255d 2023-08-04 jrmu (driver-loop)))))))
623 665c255d 2023-08-04 jrmu (internal-loop
626 665c255d 2023-08-04 jrmu (display ";;; There is no current problem")
627 665c255d 2023-08-04 jrmu (driver-loop))))
630 665c255d 2023-08-04 jrmu ;; auxiliary
631 665c255d 2023-08-04 jrmu (define (test-case actual expected)
633 665c255d 2023-08-04 jrmu (display "Actual: ")
634 665c255d 2023-08-04 jrmu (display actual)
636 665c255d 2023-08-04 jrmu (display "Expected: ")
637 665c255d 2023-08-04 jrmu (display expected)
639 665c255d 2023-08-04 jrmu (define try-again
641 665c255d 2023-08-04 jrmu "No current problem"))
642 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
643 665c255d 2023-08-04 jrmu (if (eq? exp 'try-again)
644 665c255d 2023-08-04 jrmu (try-again)
645 665c255d 2023-08-04 jrmu (ambeval exp
646 665c255d 2023-08-04 jrmu the-global-environment
647 665c255d 2023-08-04 jrmu (lambda (val next-alternative)
648 665c255d 2023-08-04 jrmu (set! try-again next-alternative)
651 665c255d 2023-08-04 jrmu (set! try-again
653 665c255d 2023-08-04 jrmu "No current problem"))
654 665c255d 2023-08-04 jrmu "No alternatives"))))
655 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
656 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
659 665c255d 2023-08-04 jrmu ;; test-suite
661 665c255d 2023-08-04 jrmu ;; procedure definitions
664 665c255d 2023-08-04 jrmu '(define (assoc key records)
665 665c255d 2023-08-04 jrmu (cond ((null? records) false)
666 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
667 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
670 665c255d 2023-08-04 jrmu '(define (map proc list)
671 665c255d 2023-08-04 jrmu (if (null? list)
673 665c255d 2023-08-04 jrmu (cons (proc (car list))
674 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
677 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
678 665c255d 2023-08-04 jrmu (if (null? sequence)
680 665c255d 2023-08-04 jrmu (op (car sequence)
681 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
683 665c255d 2023-08-04 jrmu ;; ;; all special forms
684 665c255d 2023-08-04 jrmu (test-eval '(begin 5 6) 6)
685 665c255d 2023-08-04 jrmu (test-eval '10 10)
686 665c255d 2023-08-04 jrmu (geval '(define x 3))
687 665c255d 2023-08-04 jrmu (test-eval 'x 3)
688 665c255d 2023-08-04 jrmu (test-eval '(set! x -25) 'ok)
689 665c255d 2023-08-04 jrmu (test-eval 'x -25)
690 665c255d 2023-08-04 jrmu (geval '(define z (lambda (x y) (+ x (* x y)))))
691 665c255d 2023-08-04 jrmu (test-eval '(z 3 4) 15)
692 665c255d 2023-08-04 jrmu (test-eval '(cond ((= x -2) 'x=-2)
693 665c255d 2023-08-04 jrmu ((= x -25) 'x=-25)
694 665c255d 2023-08-04 jrmu (else 'failed))
696 665c255d 2023-08-04 jrmu (test-eval '(if true false true) false)
699 665c255d 2023-08-04 jrmu '(let ((x 4) (y 7))
700 665c255d 2023-08-04 jrmu (+ x y (* x y)))
701 665c255d 2023-08-04 jrmu (+ 4 7 (* 4 7)))
705 665c255d 2023-08-04 jrmu (geval '(define x (+ 3 8)))
706 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x) 11)
707 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false) false)
708 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x (set! x -2) false) false)
709 665c255d 2023-08-04 jrmu (test-eval 'x -2)
710 665c255d 2023-08-04 jrmu (test-eval '(and 0 true x false (set! x -5)) false)
711 665c255d 2023-08-04 jrmu (test-eval 'x -2)
712 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25)) 'ok)
713 665c255d 2023-08-04 jrmu (test-eval 'x 25)
714 665c255d 2023-08-04 jrmu (test-eval '(or (set! x 2) (set! x 4)) 'ok)
715 665c255d 2023-08-04 jrmu (test-eval 'x 2)
716 665c255d 2023-08-04 jrmu (test-eval '(or false (set! x 25) true false) 'ok)
717 665c255d 2023-08-04 jrmu (test-eval 'x 25)
718 665c255d 2023-08-04 jrmu (test-eval '(or ((lambda (x) x) 5)) 5)
719 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
721 665c255d 2023-08-04 jrmu (display "Failure expected")
727 665c255d 2023-08-04 jrmu '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
728 665c255d 2023-08-04 jrmu (else false))
732 665c255d 2023-08-04 jrmu '(cond ((= 3 4) 'not-true)
733 665c255d 2023-08-04 jrmu ((= (* 2 4) 3) 'also-false)
734 665c255d 2023-08-04 jrmu ((map (lambda (x)
735 665c255d 2023-08-04 jrmu (* x (+ x 1)))
736 665c255d 2023-08-04 jrmu '(2 4 1 9))
738 665c255d 2023-08-04 jrmu (lambda (x)
739 665c255d 2023-08-04 jrmu (accumulate + 0 x)))
740 665c255d 2023-08-04 jrmu (else 'never-reach))
742 665c255d 2023-08-04 jrmu ;; '(6 20 2 90)
745 665c255d 2023-08-04 jrmu ;; procedure definition and application
747 665c255d 2023-08-04 jrmu '(define (factorial n)
748 665c255d 2023-08-04 jrmu (if (= n 0)
750 665c255d 2023-08-04 jrmu (* n (factorial (- n 1))))))
751 665c255d 2023-08-04 jrmu (test-eval '(factorial 5) 120)
756 665c255d 2023-08-04 jrmu '(map (lambda (x)
757 665c255d 2023-08-04 jrmu (* x (+ x 1)))
758 665c255d 2023-08-04 jrmu '(2 1 4 2 8 3))
759 665c255d 2023-08-04 jrmu '(6 2 20 6 72 12))
760 665c255d 2023-08-04 jrmu ;; accumulate
763 665c255d 2023-08-04 jrmu '(accumulate + 0 '(1 2 3 4 5))
766 665c255d 2023-08-04 jrmu ;; make-let
768 665c255d 2023-08-04 jrmu (make-let '(x y) '(3 5) '((+ x y)))
775 665c255d 2023-08-04 jrmu '(let ((x 3))
779 665c255d 2023-08-04 jrmu '(let ((x 3)
784 665c255d 2023-08-04 jrmu '(let ((x 3)
786 665c255d 2023-08-04 jrmu (+ (let ((x (+ y 2))
790 665c255d 2023-08-04 jrmu (+ (* 4 3) 3 2))
792 665c255d 2023-08-04 jrmu '(let ((x 6)
793 665c255d 2023-08-04 jrmu (y (let ((x 2))
795 665c255d 2023-08-04 jrmu (z (let ((a (* 3 2)))
804 665c255d 2023-08-04 jrmu '(let* ((x 3)
805 665c255d 2023-08-04 jrmu (y (+ x 2))
806 665c255d 2023-08-04 jrmu (z (+ x y 5)))
815 665c255d 2023-08-04 jrmu '(let* ((x 3))
816 665c255d 2023-08-04 jrmu (let* ((y 5))
821 665c255d 2023-08-04 jrmu '(let* ((x 3)
822 665c255d 2023-08-04 jrmu (y (+ x 1)))
823 665c255d 2023-08-04 jrmu (+ (let* ((x (+ y 2))
827 665c255d 2023-08-04 jrmu (+ (* 6 6) 3 4))
829 665c255d 2023-08-04 jrmu '(let* ((x 6)
830 665c255d 2023-08-04 jrmu (y (let* ((x 2)
831 665c255d 2023-08-04 jrmu (a (let* ((x (* 3 x)))
834 665c255d 2023-08-04 jrmu (z (+ x y)))
838 665c255d 2023-08-04 jrmu ;; named-let
841 665c255d 2023-08-04 jrmu '(let eight ()
847 665c255d 2023-08-04 jrmu '(let loop ((count 0))
848 665c255d 2023-08-04 jrmu (if (= 100 count)
850 665c255d 2023-08-04 jrmu (loop (+ count 1))))
853 665c255d 2023-08-04 jrmu '(define (prime? x)
854 665c255d 2023-08-04 jrmu (let prime-iter ((i 2))
855 665c255d 2023-08-04 jrmu (cond ((> (* i i) x) true)
856 665c255d 2023-08-04 jrmu ((= (remainder x i) 0) false)
857 665c255d 2023-08-04 jrmu (else (prime-iter (+ i 1)))))))
859 665c255d 2023-08-04 jrmu '(let primes ((x 2)
861 665c255d 2023-08-04 jrmu (cond ((= n 0) '())
862 665c255d 2023-08-04 jrmu ((prime? x)
864 665c255d 2023-08-04 jrmu (primes (+ x 1) (- n 1))))
865 665c255d 2023-08-04 jrmu (else (primes (+ x 1) n))))
866 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))
869 665c255d 2023-08-04 jrmu '(define (fib n)
870 665c255d 2023-08-04 jrmu (let fib-iter ((a 1)
873 665c255d 2023-08-04 jrmu (if (= count 0)
875 665c255d 2023-08-04 jrmu (fib-iter (+ a b) a (- count 1))))))
876 665c255d 2023-08-04 jrmu (test-eval '(fib 19) 4181)
880 665c255d 2023-08-04 jrmu '(let ((y 0))
881 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
882 665c255d 2023-08-04 jrmu ((= x 5) y)
883 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
894 665c255d 2023-08-04 jrmu '(let ((y 0))
896 665c255d 2023-08-04 jrmu ((= y 5) y)
897 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
901 665c255d 2023-08-04 jrmu '(do ((y '(1 2 3 4)))
902 665c255d 2023-08-04 jrmu ((null? y))
903 665c255d 2023-08-04 jrmu (set! y (cdr y)))
906 665c255d 2023-08-04 jrmu '(let ((y 0))
907 665c255d 2023-08-04 jrmu (do ((x 0 (+ x 1)))
908 665c255d 2023-08-04 jrmu ((= x 5) y)
909 665c255d 2023-08-04 jrmu (set! y (+ y 1))))
912 665c255d 2023-08-04 jrmu '(let ((x '(1 3 5 7 9)))
913 665c255d 2023-08-04 jrmu (do ((x x (cdr x))
914 665c255d 2023-08-04 jrmu (sum 0 (+ sum (car x))))
915 665c255d 2023-08-04 jrmu ((null? x) sum)))
918 665c255d 2023-08-04 jrmu '(let ((z '()))
919 665c255d 2023-08-04 jrmu (do ((x '(1 2 3 4) (cdr x))
920 665c255d 2023-08-04 jrmu (y '(1 2 3 4 5 6 7 8) (cddr y)))
921 665c255d 2023-08-04 jrmu ((null? x) y x z)
922 665c255d 2023-08-04 jrmu (set! z (cons (car x) z))))
923 665c255d 2023-08-04 jrmu '(4 3 2 1))
927 665c255d 2023-08-04 jrmu ;; make-unbound!
928 665c255d 2023-08-04 jrmu ;; broken now due to scan-out-defines
930 665c255d 2023-08-04 jrmu ;; (test-eval
931 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
932 665c255d 2023-08-04 jrmu ;; (let ((x 5))
933 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
934 665c255d 2023-08-04 jrmu ;; (* x x)))
937 665c255d 2023-08-04 jrmu ;; (test-eval
938 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
939 665c255d 2023-08-04 jrmu ;; (let ((x 5))
940 665c255d 2023-08-04 jrmu ;; (define y x)
941 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
942 665c255d 2023-08-04 jrmu ;; (* y x)))
945 665c255d 2023-08-04 jrmu ;; (test-eval
946 665c255d 2023-08-04 jrmu ;; '(let ((y -1) (x 3))
947 665c255d 2023-08-04 jrmu ;; (let ((y 0.5) (x 5))
948 665c255d 2023-08-04 jrmu ;; (define a x)
949 665c255d 2023-08-04 jrmu ;; (define b y)
950 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
951 665c255d 2023-08-04 jrmu ;; (make-unbound! y)
952 665c255d 2023-08-04 jrmu ;; (* a b x y)))
953 665c255d 2023-08-04 jrmu ;; (* 5 3 -1 0.5))
955 665c255d 2023-08-04 jrmu ;; (test-eval
956 665c255d 2023-08-04 jrmu ;; '(let ((x 3) (y 4))
957 665c255d 2023-08-04 jrmu ;; (let ((x 5))
958 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
959 665c255d 2023-08-04 jrmu ;; (+ x 4)))
962 665c255d 2023-08-04 jrmu ;; (test-eval
963 665c255d 2023-08-04 jrmu ;; '(let ((a 1) (b 2) (c 3) (d 4))
964 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
965 665c255d 2023-08-04 jrmu ;; (+ a c d))
966 665c255d 2023-08-04 jrmu ;; (+ 1 3 4))
968 665c255d 2023-08-04 jrmu ;; (test-eval
969 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 5))
970 665c255d 2023-08-04 jrmu ;; (let ((a 1) (b 2) (c 3))
971 665c255d 2023-08-04 jrmu ;; (let ((x (+ a b)) (y (+ c a)))
972 665c255d 2023-08-04 jrmu ;; (make-unbound! x)
973 665c255d 2023-08-04 jrmu ;; (let ((a x) (b (+ x y)))
974 665c255d 2023-08-04 jrmu ;; (define z b)
975 665c255d 2023-08-04 jrmu ;; (make-unbound! b)
976 665c255d 2023-08-04 jrmu ;; (* (+ a z)
977 665c255d 2023-08-04 jrmu ;; (+ a b y))))))
978 665c255d 2023-08-04 jrmu ;; (* (+ 4 8)
979 665c255d 2023-08-04 jrmu ;; (+ 4 2 4)))
981 665c255d 2023-08-04 jrmu ;; x 3 -- y 4
982 665c255d 2023-08-04 jrmu ;; x 4 -- y 4
983 665c255d 2023-08-04 jrmu ;; a 4 -- b 4
984 665c255d 2023-08-04 jrmu ;; a 4 -- b 2
986 665c255d 2023-08-04 jrmu ;; scan-out-defines
989 665c255d 2023-08-04 jrmu '(define (f x)
990 665c255d 2023-08-04 jrmu (define (even? n)
991 665c255d 2023-08-04 jrmu (if (= n 0)
993 665c255d 2023-08-04 jrmu (odd? (- n 1))))
994 665c255d 2023-08-04 jrmu (define (odd? n)
995 665c255d 2023-08-04 jrmu (if (= n 0)
997 665c255d 2023-08-04 jrmu (even? (- n 1))))
998 665c255d 2023-08-04 jrmu (even? x)))
999 665c255d 2023-08-04 jrmu (test-eval '(f 5) false)
1000 665c255d 2023-08-04 jrmu (test-eval '(f 10) true)
1002 665c255d 2023-08-04 jrmu ;; ;; (geval
1003 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 5))
1004 665c255d 2023-08-04 jrmu ;; ;; (define y x)
1005 665c255d 2023-08-04 jrmu ;; ;; (define x 3)
1006 665c255d 2023-08-04 jrmu ;; ;; (+ x y)))
1007 665c255d 2023-08-04 jrmu ;; ;; signal an error because x is undefined if variables are scanned out
1009 665c255d 2023-08-04 jrmu ;; ;; letrec
1012 665c255d 2023-08-04 jrmu ;; '(define (f x)
1013 665c255d 2023-08-04 jrmu ;; (letrec ((even?
1014 665c255d 2023-08-04 jrmu ;; (lambda (n)
1015 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1017 665c255d 2023-08-04 jrmu ;; (odd? (- n 1)))))
1019 665c255d 2023-08-04 jrmu ;; (lambda (n)
1020 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1022 665c255d 2023-08-04 jrmu ;; (even? (- n 1))))))
1023 665c255d 2023-08-04 jrmu ;; (even? x))))
1024 665c255d 2023-08-04 jrmu ;; (test-eval '(f 11) false)
1025 665c255d 2023-08-04 jrmu ;; (test-eval '(f 16) true)
1027 665c255d 2023-08-04 jrmu ;; (test-eval
1028 665c255d 2023-08-04 jrmu ;; '(letrec ((fact
1029 665c255d 2023-08-04 jrmu ;; (lambda (n)
1030 665c255d 2023-08-04 jrmu ;; (if (= n 1)
1032 665c255d 2023-08-04 jrmu ;; (* n (fact (- n 1)))))))
1033 665c255d 2023-08-04 jrmu ;; (fact 10))
1034 665c255d 2023-08-04 jrmu ;; 3628800)
1037 665c255d 2023-08-04 jrmu (test-eval '(amb 1 2 3) 1)
1038 665c255d 2023-08-04 jrmu (test-eval 'try-again 2)
1039 665c255d 2023-08-04 jrmu (test-eval 'try-again 3)
1040 665c255d 2023-08-04 jrmu (test-eval 'try-again "No alternatives")
1041 665c255d 2023-08-04 jrmu (test-eval 'try-again "No current problem")
1042 665c255d 2023-08-04 jrmu (test-eval 'try-again "No current problem")
1043 665c255d 2023-08-04 jrmu (test-eval '(amb (amb 1 2) (amb 'a 'b))
1045 665c255d 2023-08-04 jrmu (test-eval 'try-again 2)
1046 665c255d 2023-08-04 jrmu (test-eval 'try-again 'a)
1047 665c255d 2023-08-04 jrmu (test-eval 'try-again 'b)
1048 665c255d 2023-08-04 jrmu (test-eval 'try-again "No alternatives")
1049 665c255d 2023-08-04 jrmu (geval '(define (require p) (if (not p) (amb))))
1050 665c255d 2023-08-04 jrmu (test-eval '(require false) "No alternatives")
1051 665c255d 2023-08-04 jrmu (test-eval '(require true) false)
1055 665c255d 2023-08-04 jrmu '(define (an-integer-between low high)
1056 665c255d 2023-08-04 jrmu (require (<= low high))
1057 665c255d 2023-08-04 jrmu (amb low (an-integer-between (+ low 1) high))))
1060 665c255d 2023-08-04 jrmu '(define (a-pythagorean-triple-between low high)
1061 665c255d 2023-08-04 jrmu (let ((i (an-integer-between low high)))
1062 665c255d 2023-08-04 jrmu (let ((j (an-integer-between i high)))
1063 665c255d 2023-08-04 jrmu (let ((k (an-integer-between j high)))
1064 665c255d 2023-08-04 jrmu (require (= (+ (* i i) (* j j)) (* k k)))
1065 665c255d 2023-08-04 jrmu (list i j k))))))
1067 665c255d 2023-08-04 jrmu ;; (test-eval
1068 665c255d 2023-08-04 jrmu ;; '(a-pythagorean-triple-between 1 20)
1069 665c255d 2023-08-04 jrmu ;; '(3 4 5))
1070 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(5 12 13))
1071 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(6 8 10))
1072 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(8 15 17))
1073 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(9 12 15))
1076 665c255d 2023-08-04 jrmu '(define (an-integer-starting-from low)
1077 665c255d 2023-08-04 jrmu (amb low (an-integer-starting-from (+ low 1)))))
1080 665c255d 2023-08-04 jrmu '(define (pythagorean-triples-starting-from low)
1081 665c255d 2023-08-04 jrmu (let* ((k (an-integer-starting-from low))
1082 665c255d 2023-08-04 jrmu (i (an-integer-between low k))
1083 665c255d 2023-08-04 jrmu (j (an-integer-between i k)))
1084 665c255d 2023-08-04 jrmu (require (= (+ (* i i) (* j j)) (* k k)))
1085 665c255d 2023-08-04 jrmu (list i j k))))
1087 665c255d 2023-08-04 jrmu ;; (test-eval '(pythagorean-triples-starting-from 1)
1088 665c255d 2023-08-04 jrmu ;; '(3 4 5))
1089 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(6 8 10))
1090 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(5 12 13))
1091 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(9 12 15))
1092 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(8 15 17))
1095 665c255d 2023-08-04 jrmu '(define (next-triplet trp)
1096 665c255d 2023-08-04 jrmu (let ((i (car trp))
1097 665c255d 2023-08-04 jrmu (j (cadr trp))
1098 665c255d 2023-08-04 jrmu (k (caddr trp)))
1099 665c255d 2023-08-04 jrmu (cond ((= i j k) (list 1 1 (+ k 1)))
1100 665c255d 2023-08-04 jrmu ((= j k) (list (+ i 1) (+ i 1) k))
1101 665c255d 2023-08-04 jrmu (else (list i (+ j 1) k))))))
1103 665c255d 2023-08-04 jrmu '(define (triplet-starting-from trp)
1104 665c255d 2023-08-04 jrmu (amb trp (triplet-starting-from (next-triplet trp)))))
1106 665c255d 2023-08-04 jrmu '(define (pythagorean-triples-starting-from low)
1107 665c255d 2023-08-04 jrmu (let* ((triplet (triplet-starting-from (list low low low)))
1108 665c255d 2023-08-04 jrmu (i (car triplet))
1109 665c255d 2023-08-04 jrmu (j (cadr triplet))
1110 665c255d 2023-08-04 jrmu (k (caddr triplet)))
1111 665c255d 2023-08-04 jrmu (require (= (+ (* i i) (* j j)) (* k k)))
1112 665c255d 2023-08-04 jrmu (list i j k))))
1115 665c255d 2023-08-04 jrmu ;; (test-eval '(pythagorean-triples-starting-from 1)
1116 665c255d 2023-08-04 jrmu ;; '(3 4 5))
1117 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(6 8 10))
1118 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(5 12 13))
1119 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(9 12 15))
1120 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(8 15 17))
1123 665c255d 2023-08-04 jrmu ;; '(define (multiple-dwelling)
1124 665c255d 2023-08-04 jrmu ;; (let ((baker (amb 1 2 3 4 5))
1125 665c255d 2023-08-04 jrmu ;; (cooper (amb 1 2 3 4 5))
1126 665c255d 2023-08-04 jrmu ;; (fletcher (amb 1 2 3 4 5))
1127 665c255d 2023-08-04 jrmu ;; (miller (amb 1 2 3 4 5))
1128 665c255d 2023-08-04 jrmu ;; (smith (amb 1 2 3 4 5)))
1129 665c255d 2023-08-04 jrmu ;; (require
1130 665c255d 2023-08-04 jrmu ;; (distinct? (list baker cooper fletcher miller smith)))
1131 665c255d 2023-08-04 jrmu ;; (require (not (= baker 5)))
1132 665c255d 2023-08-04 jrmu ;; (require (not (= cooper 1)))
1133 665c255d 2023-08-04 jrmu ;; (require (not (= fletcher 5)))
1134 665c255d 2023-08-04 jrmu ;; (require (not (= fletcher 1)))
1135 665c255d 2023-08-04 jrmu ;; (require (> miller cooper))
1136 665c255d 2023-08-04 jrmu ;; (require (not (= (abs (- smith fletcher)) 1)))
1137 665c255d 2023-08-04 jrmu ;; (require (not (= (abs (- fletcher cooper)) 1)))
1138 665c255d 2023-08-04 jrmu ;; (list (list 'baker baker)
1139 665c255d 2023-08-04 jrmu ;; (list 'cooper cooper)
1140 665c255d 2023-08-04 jrmu ;; (list 'fletcher fletcher)
1141 665c255d 2023-08-04 jrmu ;; (list 'miller miller)
1142 665c255d 2023-08-04 jrmu ;; (list 'smith smith)))))
1144 665c255d 2023-08-04 jrmu '(define (distinct? items)
1145 665c255d 2023-08-04 jrmu (cond ((null? items) true)
1146 665c255d 2023-08-04 jrmu ((null? (cdr items)) true)
1147 665c255d 2023-08-04 jrmu ((member (car items) (cdr items)) false)
1148 665c255d 2023-08-04 jrmu (else (distinct? (cdr items))))))
1149 665c255d 2023-08-04 jrmu ;; (test-eval '(multiple-dwelling)
1150 665c255d 2023-08-04 jrmu ;; '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
1152 665c255d 2023-08-04 jrmu ;; Exercise 4.40. In the multiple dwelling problem, how many sets of assignments are there of people to floors, both before and after the requirement that floor assignments be distinct? It is very inefficient to generate all possible assignments of people to floors and then leave it to backtracking to eliminate them. For example, most of the restrictions depend on only one or two of the person-floor variables, and can thus be imposed before floors have been selected for all the people. Write and demonstrate a much more efficient nondeterministic procedure that solves this problem based upon generating only those possibilities that are not already ruled out by previous restrictions. (Hint: This will require a nest of let expressions.)
1155 665c255d 2023-08-04 jrmu '(define (multiple-dwelling)
1156 665c255d 2023-08-04 jrmu (let* ((fletcher (amb 2 3 4))
1157 665c255d 2023-08-04 jrmu (baker (amb 1 2 3 4))
1158 665c255d 2023-08-04 jrmu (cooper (amb 2 3 4 5)))
1159 665c255d 2023-08-04 jrmu (require (not (= (abs (- fletcher cooper)) 1)))
1160 665c255d 2023-08-04 jrmu (let ((miller (amb 1 2 3 4 5)))
1161 665c255d 2023-08-04 jrmu (require (> miller cooper))
1162 665c255d 2023-08-04 jrmu (let ((smith (amb 1 2 3 4 5)))
1163 665c255d 2023-08-04 jrmu (require (not (= (abs (- smith fletcher)) 1)))
1165 665c255d 2023-08-04 jrmu (distinct?
1166 665c255d 2023-08-04 jrmu (list baker cooper fletcher miller smith)))
1167 665c255d 2023-08-04 jrmu (list (list 'baker baker)
1168 665c255d 2023-08-04 jrmu (list 'cooper cooper)
1169 665c255d 2023-08-04 jrmu (list 'fletcher fletcher)
1170 665c255d 2023-08-04 jrmu (list 'miller miller)
1171 665c255d 2023-08-04 jrmu (list 'smith smith)))))))
1172 665c255d 2023-08-04 jrmu (test-eval '(multiple-dwelling)
1173 665c255d 2023-08-04 jrmu '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
