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 ((xor? exp) (analyze (xor->or-and-not exp)))
15 665c255d 2023-08-04 jrmu ((lambda? exp) (analyze-lambda exp))
16 665c255d 2023-08-04 jrmu ((let? exp) (analyze (let->combination exp)))
17 665c255d 2023-08-04 jrmu ((let*? exp) (analyze (let*->nested-lets exp)))
18 665c255d 2023-08-04 jrmu ((named-let? exp) (analyze (named-let->combination exp)))
19 665c255d 2023-08-04 jrmu ((letrec? exp) (analyze (letrec->let exp)))
20 665c255d 2023-08-04 jrmu ((do? exp) (analyze (do->combination exp)))
21 665c255d 2023-08-04 jrmu ((begin? exp) (analyze-sequence (begin-actions exp)))
22 665c255d 2023-08-04 jrmu ((cond? exp) (analyze (cond->if exp)))
23 665c255d 2023-08-04 jrmu ((amb? exp) (analyze-amb exp))
24 665c255d 2023-08-04 jrmu ((ramb? exp) (analyze (ramb->amb exp)))
25 665c255d 2023-08-04 jrmu ((application? exp) (analyze-application exp))
27 665c255d 2023-08-04 jrmu (error "Unknown expression type -- ANALYZE" exp))))
30 665c255d 2023-08-04 jrmu ;; analyzing procedures
31 665c255d 2023-08-04 jrmu (define (analyze-self-evaluating exp)
32 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
33 665c255d 2023-08-04 jrmu (succeed exp fail)))
34 665c255d 2023-08-04 jrmu (define (analyze-quoted exp)
35 665c255d 2023-08-04 jrmu (let ((qval (text-of-quotation exp)))
36 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
37 665c255d 2023-08-04 jrmu (succeed qval fail))))
38 665c255d 2023-08-04 jrmu (define (analyze-variable exp)
39 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
40 665c255d 2023-08-04 jrmu (succeed (lookup-variable-value exp env)
42 665c255d 2023-08-04 jrmu (define (analyze-lambda exp)
43 665c255d 2023-08-04 jrmu (let ((vars (lambda-parameters exp))
44 665c255d 2023-08-04 jrmu (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
45 665c255d 2023-08-04 jrmu ;; (bproc (analyze-sequence (lambda-body exp))))
46 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
47 665c255d 2023-08-04 jrmu (succeed (make-procedure vars bproc env)
49 665c255d 2023-08-04 jrmu (define (analyze-if exp)
50 665c255d 2023-08-04 jrmu (let ((pproc (analyze (if-predicate exp)))
51 665c255d 2023-08-04 jrmu (cproc (analyze (if-consequent exp)))
52 665c255d 2023-08-04 jrmu (aproc (analyze (if-alternative exp))))
53 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
55 665c255d 2023-08-04 jrmu ;; success continuation for evaluating the predicate
56 665c255d 2023-08-04 jrmu ;; to obtain pred-value
57 665c255d 2023-08-04 jrmu (lambda (pred-value fail2)
58 665c255d 2023-08-04 jrmu (if (true? pred-value)
59 665c255d 2023-08-04 jrmu (cproc env succeed fail2)
60 665c255d 2023-08-04 jrmu (aproc env succeed fail2)))
61 665c255d 2023-08-04 jrmu ;; failure continuation for evaluating the predicate
63 665c255d 2023-08-04 jrmu (define (analyze-sequence exps)
64 665c255d 2023-08-04 jrmu (define (sequentially a b)
65 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
67 665c255d 2023-08-04 jrmu ;; success continuation for calling a
68 665c255d 2023-08-04 jrmu (lambda (a-value fail2)
69 665c255d 2023-08-04 jrmu (b env succeed fail2))
70 665c255d 2023-08-04 jrmu ;; failure continuation for calling a
72 665c255d 2023-08-04 jrmu (define (loop first-proc rest-procs)
73 665c255d 2023-08-04 jrmu (if (null? rest-procs)
75 665c255d 2023-08-04 jrmu (loop (sequentially first-proc (car rest-procs))
76 665c255d 2023-08-04 jrmu (cdr rest-procs))))
77 665c255d 2023-08-04 jrmu (let ((procs (map analyze exps)))
78 665c255d 2023-08-04 jrmu (if (null? procs)
79 665c255d 2023-08-04 jrmu (error "Empty sequence -- ANALYZE"))
80 665c255d 2023-08-04 jrmu (loop (car procs) (cdr procs))))
81 665c255d 2023-08-04 jrmu (define (analyze-definition exp)
82 665c255d 2023-08-04 jrmu (let ((var (definition-variable exp))
83 665c255d 2023-08-04 jrmu (vproc (analyze (definition-value exp))))
84 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
86 665c255d 2023-08-04 jrmu (lambda (val fail2)
87 665c255d 2023-08-04 jrmu (define-variable! var val env)
88 665c255d 2023-08-04 jrmu (succeed 'ok fail2))
90 665c255d 2023-08-04 jrmu (define (analyze-assignment exp)
91 665c255d 2023-08-04 jrmu (let ((var (assignment-variable exp))
92 665c255d 2023-08-04 jrmu (vproc (analyze (assignment-value exp))))
93 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
95 665c255d 2023-08-04 jrmu (lambda (val fail2) ; *1*
96 665c255d 2023-08-04 jrmu (let ((old-value
97 665c255d 2023-08-04 jrmu (lookup-variable-value var env)))
98 665c255d 2023-08-04 jrmu (set-variable-value! var val env)
99 665c255d 2023-08-04 jrmu (succeed 'ok
100 665c255d 2023-08-04 jrmu (lambda () ; *2*
101 665c255d 2023-08-04 jrmu (set-variable-value! var
104 665c255d 2023-08-04 jrmu (fail2)))))
107 665c255d 2023-08-04 jrmu (define (analyze-application exp)
108 665c255d 2023-08-04 jrmu (let ((fproc (analyze (operator exp)))
109 665c255d 2023-08-04 jrmu (aprocs (map analyze (operands exp))))
110 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
112 665c255d 2023-08-04 jrmu (lambda (proc fail2)
113 665c255d 2023-08-04 jrmu (get-args aprocs
115 665c255d 2023-08-04 jrmu (lambda (args fail3)
116 665c255d 2023-08-04 jrmu (execute-application
117 665c255d 2023-08-04 jrmu proc args succeed fail3))
120 665c255d 2023-08-04 jrmu (define (get-args aprocs env succeed fail)
121 665c255d 2023-08-04 jrmu (if (null? aprocs)
122 665c255d 2023-08-04 jrmu (succeed '() fail)
123 665c255d 2023-08-04 jrmu ((car aprocs) env
124 665c255d 2023-08-04 jrmu ;; success continuation for this aproc
125 665c255d 2023-08-04 jrmu (lambda (arg fail2)
126 665c255d 2023-08-04 jrmu (get-args (cdr aprocs)
128 665c255d 2023-08-04 jrmu ;; success continuation for recursive
129 665c255d 2023-08-04 jrmu ;; call to get-args
130 665c255d 2023-08-04 jrmu (lambda (args fail3)
131 665c255d 2023-08-04 jrmu (succeed (cons arg args)
136 665c255d 2023-08-04 jrmu (define (analyze-amb exp)
137 665c255d 2023-08-04 jrmu (let ((cprocs (map analyze (amb-choices exp))))
138 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
139 665c255d 2023-08-04 jrmu (define (try-next choices)
140 665c255d 2023-08-04 jrmu (if (null? choices)
142 665c255d 2023-08-04 jrmu ((car choices) env
145 665c255d 2023-08-04 jrmu (try-next (cdr choices))))))
146 665c255d 2023-08-04 jrmu (try-next cprocs))))
153 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
154 665c255d 2023-08-04 jrmu (if (pair? exp)
155 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
158 665c255d 2023-08-04 jrmu ;; amb/ramb
159 665c255d 2023-08-04 jrmu (define (amb? exp) (tagged-list? exp 'amb))
160 665c255d 2023-08-04 jrmu (define (amb-choices exp) (cdr exp))
161 665c255d 2023-08-04 jrmu (define (make-amb choices)
162 665c255d 2023-08-04 jrmu (cons 'amb choices))
164 665c255d 2023-08-04 jrmu (define (ramb? exp)
165 665c255d 2023-08-04 jrmu (tagged-list? exp 'ramb))
166 665c255d 2023-08-04 jrmu (define (ramb->amb exp)
167 665c255d 2023-08-04 jrmu (make-amb (shuffle (amb-choices exp))))
169 665c255d 2023-08-04 jrmu (define (shuffle items)
170 665c255d 2023-08-04 jrmu (if (null? items)
172 665c255d 2023-08-04 jrmu (let ((first (list-ref items (random (length items)))))
173 665c255d 2023-08-04 jrmu (cons first
174 665c255d 2023-08-04 jrmu (shuffle (remove (lambda (i) (eq? first i))
175 665c255d 2023-08-04 jrmu items))))))
179 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
180 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
181 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
182 665c255d 2023-08-04 jrmu ((string? exp) true)
183 665c255d 2023-08-04 jrmu (else false)))
184 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
185 665c255d 2023-08-04 jrmu (define (quoted? exp)
186 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
187 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
189 665c255d 2023-08-04 jrmu ;; assignment/definition
190 665c255d 2023-08-04 jrmu (define (assignment? exp)
191 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
192 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
193 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
194 665c255d 2023-08-04 jrmu (define (make-assignment var val)
195 665c255d 2023-08-04 jrmu (list 'set! var val))
196 665c255d 2023-08-04 jrmu (define (definition? exp)
197 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
198 665c255d 2023-08-04 jrmu (define (definition-variable exp)
199 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
201 665c255d 2023-08-04 jrmu (caadr exp)))
202 665c255d 2023-08-04 jrmu (define (definition-value exp)
203 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
204 665c255d 2023-08-04 jrmu (caddr exp)
205 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
206 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
207 665c255d 2023-08-04 jrmu (define (make-definition var val)
208 665c255d 2023-08-04 jrmu `(define ,var ,val))
210 665c255d 2023-08-04 jrmu ;; if/and/or/not/xor
211 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
212 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
213 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
214 665c255d 2023-08-04 jrmu (define (if-alternative exp)
215 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
216 665c255d 2023-08-04 jrmu (cadddr exp)
218 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
219 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
221 665c255d 2023-08-04 jrmu (define (and? exp)
222 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
223 665c255d 2023-08-04 jrmu (define (and-clauses exp)
225 665c255d 2023-08-04 jrmu (define (or? exp)
226 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
227 665c255d 2023-08-04 jrmu (define (or-clauses exp)
229 665c255d 2023-08-04 jrmu (define (and->if exp)
230 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
231 665c255d 2023-08-04 jrmu (cond ((null? clauses) 'true)
232 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (car clauses))
233 665c255d 2023-08-04 jrmu (else (make-if (car clauses)
234 665c255d 2023-08-04 jrmu (expand-clauses (cdr clauses))
236 665c255d 2023-08-04 jrmu (expand-clauses (and-clauses exp)))
237 665c255d 2023-08-04 jrmu (define (or->if exp)
238 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
239 665c255d 2023-08-04 jrmu (if (null? clauses)
241 665c255d 2023-08-04 jrmu (make-if (car clauses)
242 665c255d 2023-08-04 jrmu (car clauses)
243 665c255d 2023-08-04 jrmu (expand-clauses (cdr clauses)))))
244 665c255d 2023-08-04 jrmu (expand-clauses (or-clauses exp)))
245 665c255d 2023-08-04 jrmu (define (not? exp)
246 665c255d 2023-08-04 jrmu (tagged-list? exp 'not))
247 665c255d 2023-08-04 jrmu (define (not->if exp)
248 665c255d 2023-08-04 jrmu `(if ,(cadr exp) false true))
249 665c255d 2023-08-04 jrmu (define (xor? exp)
250 665c255d 2023-08-04 jrmu (tagged-list? exp 'xor))
251 665c255d 2023-08-04 jrmu (define (xor->or-and-not exp)
252 665c255d 2023-08-04 jrmu (let ((pred-1 (cadr exp))
253 665c255d 2023-08-04 jrmu (pred-2 (caddr exp)))
254 665c255d 2023-08-04 jrmu `(or (and ,pred-1 (not ,pred-2))
255 665c255d 2023-08-04 jrmu (and (not ,pred-1) ,pred-2))))
257 665c255d 2023-08-04 jrmu ;; lambda/let/let*/letrec
258 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
259 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
260 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
261 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
262 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
264 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
266 665c255d 2023-08-04 jrmu (cons (map list vars vals)
268 665c255d 2023-08-04 jrmu (define (let? exp)
269 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
270 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
271 665c255d 2023-08-04 jrmu (define (let-vars exp)
272 665c255d 2023-08-04 jrmu (map car (cadr exp)))
273 665c255d 2023-08-04 jrmu (define (let-vals exp)
274 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
275 665c255d 2023-08-04 jrmu (define (let-body exp)
276 665c255d 2023-08-04 jrmu (cddr exp))
277 665c255d 2023-08-04 jrmu (define (let->combination exp)
278 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
279 665c255d 2023-08-04 jrmu (let-vals exp)))
280 665c255d 2023-08-04 jrmu (define (named-let? exp)
281 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
282 665c255d 2023-08-04 jrmu v (symbol? (cadr exp))))
283 665c255d 2023-08-04 jrmu (define (named-let-name exp)
284 665c255d 2023-08-04 jrmu (cadr exp))
285 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
286 665c255d 2023-08-04 jrmu (map car (caddr exp)))
287 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
288 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
289 665c255d 2023-08-04 jrmu (define (named-let-body exp)
290 665c255d 2023-08-04 jrmu (cdddr exp))
291 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
292 665c255d 2023-08-04 jrmu (sequence->exp
293 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
294 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
295 665c255d 2023-08-04 jrmu (named-let-body exp)))
296 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
297 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
298 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
301 665c255d 2023-08-04 jrmu (cons (map list vars vals)
304 665c255d 2023-08-04 jrmu (define (letrec? exp)
305 665c255d 2023-08-04 jrmu (tagged-list? exp 'letrec))
307 665c255d 2023-08-04 jrmu (define (letrec-vars exp)
308 665c255d 2023-08-04 jrmu (map car (cadr exp)))
309 665c255d 2023-08-04 jrmu (define (letrec-vals exp)
310 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
311 665c255d 2023-08-04 jrmu (define (letrec-body exp)
312 665c255d 2023-08-04 jrmu (cddr exp))
313 665c255d 2023-08-04 jrmu (define (letrec->let exp)
314 665c255d 2023-08-04 jrmu (let* ((vars (letrec-vars exp))
315 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
317 665c255d 2023-08-04 jrmu (vals (letrec-vals exp))
318 665c255d 2023-08-04 jrmu (assignments (map (lambda (var val)
319 665c255d 2023-08-04 jrmu (make-assignment var val))
322 665c255d 2023-08-04 jrmu (body (letrec-body exp)))
323 665c255d 2023-08-04 jrmu (make-let vars
324 665c255d 2023-08-04 jrmu unassigneds
325 665c255d 2023-08-04 jrmu (append assignments body))))
327 665c255d 2023-08-04 jrmu (define (make-application op args)
328 665c255d 2023-08-04 jrmu (cons op args))
330 665c255d 2023-08-04 jrmu (define (let*? exp)
331 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
332 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
333 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
334 665c255d 2023-08-04 jrmu (define let*-body let-body)
335 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
336 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
337 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
338 665c255d 2023-08-04 jrmu (make-let (list (car vars))
339 665c255d 2023-08-04 jrmu (list (car vals))
340 665c255d 2023-08-04 jrmu (let*-body exp))
341 665c255d 2023-08-04 jrmu (make-let (list (car vars))
342 665c255d 2023-08-04 jrmu (list (car vals))
343 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
344 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
345 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
346 665c255d 2023-08-04 jrmu (if (null? vars)
347 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
348 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
351 665c255d 2023-08-04 jrmu (define (do? exp)
352 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
353 665c255d 2023-08-04 jrmu (define (do-vars exp)
354 665c255d 2023-08-04 jrmu (map car (cadr exp)))
355 665c255d 2023-08-04 jrmu (define (do-inits exp)
356 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
357 665c255d 2023-08-04 jrmu (define (do-steps exp)
358 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
359 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
360 665c255d 2023-08-04 jrmu (car var-init-step)
361 665c255d 2023-08-04 jrmu (caddr var-init-step)))
362 665c255d 2023-08-04 jrmu (cadr exp)))
363 665c255d 2023-08-04 jrmu (define (do-test exp)
364 665c255d 2023-08-04 jrmu (caaddr exp))
365 665c255d 2023-08-04 jrmu (define (do-expressions exp)
366 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
367 665c255d 2023-08-04 jrmu (caddr exp)
368 665c255d 2023-08-04 jrmu (cdaddr exp)))
369 665c255d 2023-08-04 jrmu (define (do-commands exp)
370 665c255d 2023-08-04 jrmu (cdddr exp))
371 665c255d 2023-08-04 jrmu (define (do->combination exp)
372 665c255d 2023-08-04 jrmu (make-named-let
374 665c255d 2023-08-04 jrmu (do-vars exp)
375 665c255d 2023-08-04 jrmu (do-inits exp)
378 665c255d 2023-08-04 jrmu (do-test exp)
379 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
380 665c255d 2023-08-04 jrmu (sequence->exp
381 665c255d 2023-08-04 jrmu (append (do-commands exp)
382 665c255d 2023-08-04 jrmu (list (make-application
384 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
387 665c255d 2023-08-04 jrmu ;; begin/sequence
388 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
389 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
390 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
391 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
392 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
393 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
394 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
395 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
396 665c255d 2023-08-04 jrmu (else (make-begin seq))))
397 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
399 665c255d 2023-08-04 jrmu ;; application
400 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
401 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
402 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
403 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
404 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
405 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
408 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
409 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
410 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
411 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
412 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
413 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
414 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
415 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
416 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
417 665c255d 2023-08-04 jrmu (caddr clause))
418 665c255d 2023-08-04 jrmu (define (cond->if exp)
419 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
420 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
421 665c255d 2023-08-04 jrmu (if (null? clauses)
422 665c255d 2023-08-04 jrmu 'false ; no else clause
423 665c255d 2023-08-04 jrmu (let ((first (car clauses))
424 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
425 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
426 665c255d 2023-08-04 jrmu (if (null? rest)
427 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
428 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
430 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
431 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
432 665c255d 2023-08-04 jrmu (make-application
433 665c255d 2023-08-04 jrmu (cond-extended-proc first)
434 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
435 665c255d 2023-08-04 jrmu (expand-clauses rest))
436 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
437 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
438 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
439 665c255d 2023-08-04 jrmu (define (true? x)
440 665c255d 2023-08-04 jrmu (not (eq? x false)))
441 665c255d 2023-08-04 jrmu (define (false? x)
442 665c255d 2023-08-04 jrmu (eq? x false))
444 665c255d 2023-08-04 jrmu ;; procedure
445 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
446 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
447 665c255d 2023-08-04 jrmu (define (scan-out-defines body)
448 665c255d 2023-08-04 jrmu (let* ((definitions (filter definition? body))
449 665c255d 2023-08-04 jrmu (vars (map definition-variable definitions))
450 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
452 665c255d 2023-08-04 jrmu (vals (map definition-value definitions))
453 665c255d 2023-08-04 jrmu (assignments
454 665c255d 2023-08-04 jrmu (map (lambda (var val)
455 665c255d 2023-08-04 jrmu (make-assignment var val))
456 665c255d 2023-08-04 jrmu vars vals))
457 665c255d 2023-08-04 jrmu (exps (remove definition? body)))
458 665c255d 2023-08-04 jrmu (if (null? definitions)
461 665c255d 2023-08-04 jrmu (make-let vars
462 665c255d 2023-08-04 jrmu unassigneds
463 665c255d 2023-08-04 jrmu (append assignments exps))))))
464 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
465 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
466 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
467 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
468 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
470 665c255d 2023-08-04 jrmu ;; environment
471 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
472 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
473 665c255d 2023-08-04 jrmu (define the-empty-environment '())
474 665c255d 2023-08-04 jrmu (define (make-frame variables values)
475 665c255d 2023-08-04 jrmu (cons variables values))
476 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
477 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
478 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
479 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
480 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
481 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
482 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
483 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
484 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
485 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
486 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
487 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
488 665c255d 2023-08-04 jrmu (define (env-loop env)
489 665c255d 2023-08-04 jrmu (define (scan vars vals)
490 665c255d 2023-08-04 jrmu (cond ((null? vars)
491 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
492 665c255d 2023-08-04 jrmu ((eq? var (car vars))
493 665c255d 2023-08-04 jrmu ;; (let ((val (car vals)))
494 665c255d 2023-08-04 jrmu ;; (if (eq? val '*unassigned*)
495 665c255d 2023-08-04 jrmu ;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
497 665c255d 2023-08-04 jrmu (car vals))
498 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
499 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
500 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
501 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
502 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
503 665c255d 2023-08-04 jrmu (frame-values frame)))))
504 665c255d 2023-08-04 jrmu (env-loop env))
505 665c255d 2023-08-04 jrmu (define (set-variable-value! var val env)
506 665c255d 2023-08-04 jrmu (define (env-loop env)
507 665c255d 2023-08-04 jrmu (define (scan vars vals)
508 665c255d 2023-08-04 jrmu (cond ((null? vars)
509 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
510 665c255d 2023-08-04 jrmu ((eq? var (car vars))
511 665c255d 2023-08-04 jrmu (set-car! vals val))
512 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
513 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
514 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
515 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
516 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
517 665c255d 2023-08-04 jrmu (frame-values frame)))))
518 665c255d 2023-08-04 jrmu (env-loop env))
519 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
520 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
521 665c255d 2023-08-04 jrmu (define (scan vars vals)
522 665c255d 2023-08-04 jrmu (cond ((null? vars)
523 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
524 665c255d 2023-08-04 jrmu ((eq? var (car vars))
525 665c255d 2023-08-04 jrmu (set-car! vals val))
526 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
527 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
528 665c255d 2023-08-04 jrmu (frame-values frame))))
530 665c255d 2023-08-04 jrmu ;; (define (remove-binding-from-frame! var frame)
531 665c255d 2023-08-04 jrmu ;; (define (scan vars vals)
532 665c255d 2023-08-04 jrmu ;; (cond ((null? (cdr vars))
533 665c255d 2023-08-04 jrmu ;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
534 665c255d 2023-08-04 jrmu ;; ((eq? var (cadr vars))
535 665c255d 2023-08-04 jrmu ;; (set-cdr! vars (cddr vars))
536 665c255d 2023-08-04 jrmu ;; (set-cdr! vals (cddr vals)))
537 665c255d 2023-08-04 jrmu ;; (else (scan (cdr vars) (cdr vals)))))
538 665c255d 2023-08-04 jrmu ;; (let ((vars (frame-variables frame))
539 665c255d 2023-08-04 jrmu ;; (vals (frame-values frame)))
540 665c255d 2023-08-04 jrmu ;; (if (eq? var (car vars))
541 665c255d 2023-08-04 jrmu ;; (begin (set-car! frame (cdr vars))
542 665c255d 2023-08-04 jrmu ;; (set-cdr! frame (cdr vals)))
543 665c255d 2023-08-04 jrmu ;; (scan vars vals))))
545 665c255d 2023-08-04 jrmu ;; primitives
546 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
547 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
548 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
549 665c255d 2023-08-04 jrmu (define primitive-procedures
550 665c255d 2023-08-04 jrmu (list (list 'car car)
551 665c255d 2023-08-04 jrmu (list 'cdr cdr)
552 665c255d 2023-08-04 jrmu (list 'caar caar)
553 665c255d 2023-08-04 jrmu (list 'cadr cadr)
554 665c255d 2023-08-04 jrmu (list 'cddr cddr)
555 665c255d 2023-08-04 jrmu (list 'caddr caddr)
556 665c255d 2023-08-04 jrmu (list 'cdddr cdddr)
557 665c255d 2023-08-04 jrmu (list 'cons cons)
558 665c255d 2023-08-04 jrmu (list 'list list)
559 665c255d 2023-08-04 jrmu (list 'null? null?)
560 665c255d 2023-08-04 jrmu (list 'pair? pair?)
561 665c255d 2023-08-04 jrmu (list '* *)
562 665c255d 2023-08-04 jrmu (list '/ /)
563 665c255d 2023-08-04 jrmu (list '+ +)
564 665c255d 2023-08-04 jrmu (list '- -)
565 665c255d 2023-08-04 jrmu (list '= =)
566 665c255d 2023-08-04 jrmu (list '< <)
567 665c255d 2023-08-04 jrmu (list '> >)
568 665c255d 2023-08-04 jrmu (list '<= <=)
569 665c255d 2023-08-04 jrmu (list '>= >=)
570 665c255d 2023-08-04 jrmu (list 'abs abs)
571 665c255d 2023-08-04 jrmu (list 'remainder remainder)
572 665c255d 2023-08-04 jrmu (list 'eq? eq?)
573 665c255d 2023-08-04 jrmu (list 'equal? equal?)
574 665c255d 2023-08-04 jrmu (list 'member member)
575 665c255d 2023-08-04 jrmu (list 'memq memq)
576 665c255d 2023-08-04 jrmu (list 'display display)
577 665c255d 2023-08-04 jrmu (list 'error error)))
578 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
580 665c255d 2023-08-04 jrmu primitive-procedures))
581 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
582 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
583 665c255d 2023-08-04 jrmu primitive-procedures))
584 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
586 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
588 665c255d 2023-08-04 jrmu ;; execute application
590 665c255d 2023-08-04 jrmu (define (execute-application proc args succeed fail)
591 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? proc)
592 665c255d 2023-08-04 jrmu (succeed (apply-primitive-procedure proc args)
594 665c255d 2023-08-04 jrmu ((compound-procedure? proc)
595 665c255d 2023-08-04 jrmu ((procedure-body proc)
596 665c255d 2023-08-04 jrmu (extend-environment (procedure-parameters proc)
598 665c255d 2023-08-04 jrmu (procedure-environment proc))
603 665c255d 2023-08-04 jrmu "Unknown procedure type -- EXECUTE-APPLICATION"
607 665c255d 2023-08-04 jrmu ;; driver-loop
608 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
609 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
610 665c255d 2023-08-04 jrmu (define (announce-output string)
611 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
612 665c255d 2023-08-04 jrmu (define (user-print object)
613 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
614 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
615 665c255d 2023-08-04 jrmu (procedure-parameters object)
616 665c255d 2023-08-04 jrmu (procedure-body object)
617 665c255d 2023-08-04 jrmu '<procedure-env>))
618 665c255d 2023-08-04 jrmu (display object)))
619 665c255d 2023-08-04 jrmu (define (setup-environment)
620 665c255d 2023-08-04 jrmu (let ((initial-env
621 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
622 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
623 665c255d 2023-08-04 jrmu the-empty-environment)))
624 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
625 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
626 665c255d 2023-08-04 jrmu initial-env))
627 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
629 665c255d 2023-08-04 jrmu (define input-prompt ";;; Amb-Eval input:")
630 665c255d 2023-08-04 jrmu (define output-prompt ";;; Amb-Eval value:")
631 665c255d 2023-08-04 jrmu (define (driver-loop)
632 665c255d 2023-08-04 jrmu (define (internal-loop try-again)
633 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
634 665c255d 2023-08-04 jrmu (let ((input (read)))
635 665c255d 2023-08-04 jrmu (if (eq? input 'try-again)
636 665c255d 2023-08-04 jrmu (try-again)
639 665c255d 2023-08-04 jrmu (display ";;; Starting a new problem ")
640 665c255d 2023-08-04 jrmu (ambeval input
641 665c255d 2023-08-04 jrmu the-global-environment
642 665c255d 2023-08-04 jrmu ;; ambeval success
643 665c255d 2023-08-04 jrmu (lambda (val next-alternative)
644 665c255d 2023-08-04 jrmu (announce-output output-prompt)
645 665c255d 2023-08-04 jrmu (user-print val)
646 665c255d 2023-08-04 jrmu (internal-loop next-alternative))
647 665c255d 2023-08-04 jrmu ;; ambeval failure
649 665c255d 2023-08-04 jrmu (announce-output
650 665c255d 2023-08-04 jrmu ";;; There are no more values of")
651 665c255d 2023-08-04 jrmu (user-print input)
652 665c255d 2023-08-04 jrmu (driver-loop)))))))
653 665c255d 2023-08-04 jrmu (internal-loop
656 665c255d 2023-08-04 jrmu (display ";;; There is no current problem")
657 665c255d 2023-08-04 jrmu (driver-loop))))
660 665c255d 2023-08-04 jrmu ;; auxiliary
661 665c255d 2023-08-04 jrmu (define (test-case actual expected)
663 665c255d 2023-08-04 jrmu (display "Actual: ")
664 665c255d 2023-08-04 jrmu (display actual)
666 665c255d 2023-08-04 jrmu (display "Expected: ")
667 665c255d 2023-08-04 jrmu (display expected)
669 665c255d 2023-08-04 jrmu (define try-again
671 665c255d 2023-08-04 jrmu "No current problem"))
672 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
673 665c255d 2023-08-04 jrmu (if (eq? exp 'try-again)
674 665c255d 2023-08-04 jrmu (try-again)
675 665c255d 2023-08-04 jrmu (ambeval exp
676 665c255d 2023-08-04 jrmu the-global-environment
677 665c255d 2023-08-04 jrmu (lambda (val next-alternative)
678 665c255d 2023-08-04 jrmu (set! try-again next-alternative)
681 665c255d 2023-08-04 jrmu (set! try-again
683 665c255d 2023-08-04 jrmu "No current problem"))
684 665c255d 2023-08-04 jrmu "No alternatives"))))
685 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
686 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
687 665c255d 2023-08-04 jrmu (define (print-eval exp)
688 665c255d 2023-08-04 jrmu (user-print (geval exp)))
690 665c255d 2023-08-04 jrmu ;; test-suite
692 665c255d 2023-08-04 jrmu ;; procedure definitions
695 665c255d 2023-08-04 jrmu '(define (append x y)
696 665c255d 2023-08-04 jrmu (if (null? x)
698 665c255d 2023-08-04 jrmu (cons (car x) (append (cdr x) y)))))
700 665c255d 2023-08-04 jrmu '(define (list-ref items n)
701 665c255d 2023-08-04 jrmu (if (= n 0)
702 665c255d 2023-08-04 jrmu (car items)
703 665c255d 2023-08-04 jrmu (list-ref (cdr items) (- n 1)))))
705 665c255d 2023-08-04 jrmu '(define (fold-left f init seq)
706 665c255d 2023-08-04 jrmu (if (null? seq)
708 665c255d 2023-08-04 jrmu (fold-left f
709 665c255d 2023-08-04 jrmu (f init (car seq))
710 665c255d 2023-08-04 jrmu (cdr seq)))))
712 665c255d 2023-08-04 jrmu '(define (enumerate-interval low high)
713 665c255d 2023-08-04 jrmu (if (> low high)
715 665c255d 2023-08-04 jrmu (cons low (enumerate-interval (+ low 1) high)))))
717 665c255d 2023-08-04 jrmu '(define (assoc key records)
718 665c255d 2023-08-04 jrmu (cond ((null? records) false)
719 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
720 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
723 665c255d 2023-08-04 jrmu '(define (map proc list)
724 665c255d 2023-08-04 jrmu (if (null? list)
726 665c255d 2023-08-04 jrmu (cons (proc (car list))
727 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
729 665c255d 2023-08-04 jrmu '(define (map-2 proc l1 l2)
730 665c255d 2023-08-04 jrmu (if (null? l1)
732 665c255d 2023-08-04 jrmu (cons (proc (car l1) (car l2))
733 665c255d 2023-08-04 jrmu (map-2 proc (cdr l1) (cdr l2))))))
736 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
737 665c255d 2023-08-04 jrmu (if (null? sequence)
739 665c255d 2023-08-04 jrmu (op (car sequence)
740 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
742 665c255d 2023-08-04 jrmu ;; ;; ;; all special forms
743 665c255d 2023-08-04 jrmu ;; (test-eval '(begin 5 6) 6)
744 665c255d 2023-08-04 jrmu ;; (test-eval '10 10)
745 665c255d 2023-08-04 jrmu ;; (geval '(define x 3))
746 665c255d 2023-08-04 jrmu ;; (test-eval 'x 3)
747 665c255d 2023-08-04 jrmu ;; (test-eval '(set! x -25) 'ok)
748 665c255d 2023-08-04 jrmu ;; (test-eval 'x -25)
749 665c255d 2023-08-04 jrmu ;; (geval '(define z (lambda (x y) (+ x (* x y)))))
750 665c255d 2023-08-04 jrmu ;; (test-eval '(z 3 4) 15)
751 665c255d 2023-08-04 jrmu ;; (test-eval '(cond ((= x -2) 'x=-2)
752 665c255d 2023-08-04 jrmu ;; ((= x -25) 'x=-25)
753 665c255d 2023-08-04 jrmu ;; (else 'failed))
755 665c255d 2023-08-04 jrmu ;; (test-eval '(if true false true) false)
757 665c255d 2023-08-04 jrmu ;; (test-eval
758 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 7))
759 665c255d 2023-08-04 jrmu ;; (+ x y (* x y)))
760 665c255d 2023-08-04 jrmu ;; (+ 4 7 (* 4 7)))
763 665c255d 2023-08-04 jrmu ;; ;; and/or
764 665c255d 2023-08-04 jrmu ;; (geval '(define x (+ 3 8)))
765 665c255d 2023-08-04 jrmu ;; (test-eval '(and 0 true x) 11)
766 665c255d 2023-08-04 jrmu ;; (test-eval '(and 0 true x false) false)
767 665c255d 2023-08-04 jrmu ;; (test-eval '(and 0 true x (set! x -2) false) false)
768 665c255d 2023-08-04 jrmu ;; (test-eval 'x -2)
769 665c255d 2023-08-04 jrmu ;; (test-eval '(and 0 true x false (set! x -5)) false)
770 665c255d 2023-08-04 jrmu ;; (test-eval 'x -2)
771 665c255d 2023-08-04 jrmu ;; (test-eval '(or false (set! x 25)) 'ok)
772 665c255d 2023-08-04 jrmu ;; (test-eval 'x 25)
773 665c255d 2023-08-04 jrmu ;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
774 665c255d 2023-08-04 jrmu ;; (test-eval 'x 2)
775 665c255d 2023-08-04 jrmu ;; (test-eval '(or false (set! x 25) true false) 'ok)
776 665c255d 2023-08-04 jrmu ;; (test-eval 'x 25)
777 665c255d 2023-08-04 jrmu ;; (test-eval '(or ((lambda (x) x) 5)) 5)
778 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
779 665c255d 2023-08-04 jrmu ;; (newline)
780 665c255d 2023-08-04 jrmu ;; (display "Failure expected")
781 665c255d 2023-08-04 jrmu ;; (newline)
785 665c255d 2023-08-04 jrmu ;; (test-eval
786 665c255d 2023-08-04 jrmu ;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
787 665c255d 2023-08-04 jrmu ;; (else false))
790 665c255d 2023-08-04 jrmu ;; (test-eval
791 665c255d 2023-08-04 jrmu ;; '(cond ((= 3 4) 'not-true)
792 665c255d 2023-08-04 jrmu ;; ((= (* 2 4) 3) 'also-false)
793 665c255d 2023-08-04 jrmu ;; ((map (lambda (x)
794 665c255d 2023-08-04 jrmu ;; (* x (+ x 1)))
795 665c255d 2023-08-04 jrmu ;; '(2 4 1 9))
797 665c255d 2023-08-04 jrmu ;; (lambda (x)
798 665c255d 2023-08-04 jrmu ;; (accumulate + 0 x)))
799 665c255d 2023-08-04 jrmu ;; (else 'never-reach))
801 665c255d 2023-08-04 jrmu ;; ;; '(6 20 2 90)
804 665c255d 2023-08-04 jrmu ;; ;; procedure definition and application
806 665c255d 2023-08-04 jrmu ;; '(define (factorial n)
807 665c255d 2023-08-04 jrmu ;; (if (= n 0)
809 665c255d 2023-08-04 jrmu ;; (* n (factorial (- n 1))))))
810 665c255d 2023-08-04 jrmu ;; (test-eval '(factorial 5) 120)
814 665c255d 2023-08-04 jrmu ;; (test-eval
815 665c255d 2023-08-04 jrmu ;; '(map (lambda (x)
816 665c255d 2023-08-04 jrmu ;; (* x (+ x 1)))
817 665c255d 2023-08-04 jrmu ;; '(2 1 4 2 8 3))
818 665c255d 2023-08-04 jrmu ;; '(6 2 20 6 72 12))
819 665c255d 2023-08-04 jrmu ;; ;; accumulate
821 665c255d 2023-08-04 jrmu ;; (test-eval
822 665c255d 2023-08-04 jrmu ;; '(accumulate + 0 '(1 2 3 4 5))
825 665c255d 2023-08-04 jrmu ;; ;; make-let
826 665c255d 2023-08-04 jrmu ;; (test-eval
827 665c255d 2023-08-04 jrmu ;; (make-let '(x y) '(3 5) '((+ x y)))
829 665c255d 2023-08-04 jrmu ;; (test-eval
830 665c255d 2023-08-04 jrmu ;; '(let ()
833 665c255d 2023-08-04 jrmu ;; (test-eval
834 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
837 665c255d 2023-08-04 jrmu ;; (test-eval
838 665c255d 2023-08-04 jrmu ;; '(let ((x 3)
840 665c255d 2023-08-04 jrmu ;; (+ x y))
842 665c255d 2023-08-04 jrmu ;; (test-eval
843 665c255d 2023-08-04 jrmu ;; '(let ((x 3)
845 665c255d 2023-08-04 jrmu ;; (+ (let ((x (+ y 2))
847 665c255d 2023-08-04 jrmu ;; (* x y))
849 665c255d 2023-08-04 jrmu ;; (+ (* 4 3) 3 2))
850 665c255d 2023-08-04 jrmu ;; (test-eval
851 665c255d 2023-08-04 jrmu ;; '(let ((x 6)
852 665c255d 2023-08-04 jrmu ;; (y (let ((x 2))
853 665c255d 2023-08-04 jrmu ;; (+ x 3)))
854 665c255d 2023-08-04 jrmu ;; (z (let ((a (* 3 2)))
855 665c255d 2023-08-04 jrmu ;; (+ a 3))))
856 665c255d 2023-08-04 jrmu ;; (+ x y z))
857 665c255d 2023-08-04 jrmu ;; (+ 6 5 9))
862 665c255d 2023-08-04 jrmu ;; (test-eval
863 665c255d 2023-08-04 jrmu ;; '(let* ((x 3)
864 665c255d 2023-08-04 jrmu ;; (y (+ x 2))
865 665c255d 2023-08-04 jrmu ;; (z (+ x y 5)))
866 665c255d 2023-08-04 jrmu ;; (* x z))
869 665c255d 2023-08-04 jrmu ;; (test-eval
870 665c255d 2023-08-04 jrmu ;; '(let* ()
873 665c255d 2023-08-04 jrmu ;; (test-eval
874 665c255d 2023-08-04 jrmu ;; '(let* ((x 3))
875 665c255d 2023-08-04 jrmu ;; (let* ((y 5))
876 665c255d 2023-08-04 jrmu ;; (+ x y)))
879 665c255d 2023-08-04 jrmu ;; (test-eval
880 665c255d 2023-08-04 jrmu ;; '(let* ((x 3)
881 665c255d 2023-08-04 jrmu ;; (y (+ x 1)))
882 665c255d 2023-08-04 jrmu ;; (+ (let* ((x (+ y 2))
884 665c255d 2023-08-04 jrmu ;; (* x y))
886 665c255d 2023-08-04 jrmu ;; (+ (* 6 6) 3 4))
887 665c255d 2023-08-04 jrmu ;; (test-eval
888 665c255d 2023-08-04 jrmu ;; '(let* ((x 6)
889 665c255d 2023-08-04 jrmu ;; (y (let* ((x 2)
890 665c255d 2023-08-04 jrmu ;; (a (let* ((x (* 3 x)))
891 665c255d 2023-08-04 jrmu ;; (+ x 2))))
892 665c255d 2023-08-04 jrmu ;; (+ x a)))
893 665c255d 2023-08-04 jrmu ;; (z (+ x y)))
894 665c255d 2023-08-04 jrmu ;; (+ x y z))
897 665c255d 2023-08-04 jrmu ;; ;; named-let
899 665c255d 2023-08-04 jrmu ;; (test-eval
900 665c255d 2023-08-04 jrmu ;; '(let eight ()
905 665c255d 2023-08-04 jrmu ;; (test-eval
906 665c255d 2023-08-04 jrmu ;; '(let loop ((count 0))
907 665c255d 2023-08-04 jrmu ;; (if (= 100 count)
909 665c255d 2023-08-04 jrmu ;; (loop (+ count 1))))
912 665c255d 2023-08-04 jrmu ;; '(define (prime? x)
913 665c255d 2023-08-04 jrmu ;; (let prime-iter ((i 2))
914 665c255d 2023-08-04 jrmu ;; (cond ((> (* i i) x) true)
915 665c255d 2023-08-04 jrmu ;; ((= (remainder x i) 0) false)
916 665c255d 2023-08-04 jrmu ;; (else (prime-iter (+ i 1)))))))
917 665c255d 2023-08-04 jrmu ;; (test-eval
918 665c255d 2023-08-04 jrmu ;; '(let primes ((x 2)
920 665c255d 2023-08-04 jrmu ;; (cond ((= n 0) '())
921 665c255d 2023-08-04 jrmu ;; ((prime? x)
923 665c255d 2023-08-04 jrmu ;; (primes (+ x 1) (- n 1))))
924 665c255d 2023-08-04 jrmu ;; (else (primes (+ x 1) n))))
925 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))
928 665c255d 2023-08-04 jrmu ;; '(define (fib n)
929 665c255d 2023-08-04 jrmu ;; (let fib-iter ((a 1)
931 665c255d 2023-08-04 jrmu ;; (count n))
932 665c255d 2023-08-04 jrmu ;; (if (= count 0)
934 665c255d 2023-08-04 jrmu ;; (fib-iter (+ a b) a (- count 1))))))
935 665c255d 2023-08-04 jrmu ;; (test-eval '(fib 19) 4181)
937 665c255d 2023-08-04 jrmu ;; ;; do-loop
938 665c255d 2023-08-04 jrmu ;; (test-eval
939 665c255d 2023-08-04 jrmu ;; '(let ((y 0))
940 665c255d 2023-08-04 jrmu ;; (do ((x 0 (+ x 1)))
941 665c255d 2023-08-04 jrmu ;; ((= x 5) y)
942 665c255d 2023-08-04 jrmu ;; (set! y (+ y 1))))
944 665c255d 2023-08-04 jrmu ;; (test-eval
948 665c255d 2023-08-04 jrmu ;; (test-eval
950 665c255d 2023-08-04 jrmu ;; (true 5))
952 665c255d 2023-08-04 jrmu ;; (test-eval
953 665c255d 2023-08-04 jrmu ;; '(let ((y 0))
955 665c255d 2023-08-04 jrmu ;; ((= y 5) y)
956 665c255d 2023-08-04 jrmu ;; (set! y (+ y 1))))
959 665c255d 2023-08-04 jrmu ;; (test-eval
960 665c255d 2023-08-04 jrmu ;; '(do ((y '(1 2 3 4)))
961 665c255d 2023-08-04 jrmu ;; ((null? y))
962 665c255d 2023-08-04 jrmu ;; (set! y (cdr y)))
964 665c255d 2023-08-04 jrmu ;; (test-eval
965 665c255d 2023-08-04 jrmu ;; '(let ((y 0))
966 665c255d 2023-08-04 jrmu ;; (do ((x 0 (+ x 1)))
967 665c255d 2023-08-04 jrmu ;; ((= x 5) y)
968 665c255d 2023-08-04 jrmu ;; (set! y (+ y 1))))
970 665c255d 2023-08-04 jrmu ;; (test-eval
971 665c255d 2023-08-04 jrmu ;; '(let ((x '(1 3 5 7 9)))
972 665c255d 2023-08-04 jrmu ;; (do ((x x (cdr x))
973 665c255d 2023-08-04 jrmu ;; (sum 0 (+ sum (car x))))
974 665c255d 2023-08-04 jrmu ;; ((null? x) sum)))
976 665c255d 2023-08-04 jrmu ;; (test-eval
977 665c255d 2023-08-04 jrmu ;; '(let ((z '()))
978 665c255d 2023-08-04 jrmu ;; (do ((x '(1 2 3 4) (cdr x))
979 665c255d 2023-08-04 jrmu ;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
980 665c255d 2023-08-04 jrmu ;; ((null? x) y x z)
981 665c255d 2023-08-04 jrmu ;; (set! z (cons (car x) z))))
982 665c255d 2023-08-04 jrmu ;; '(4 3 2 1))
986 665c255d 2023-08-04 jrmu ;; ;; make-unbound!
987 665c255d 2023-08-04 jrmu ;; ;; broken now due to scan-out-defines
989 665c255d 2023-08-04 jrmu ;; ;; (test-eval
990 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 3))
991 665c255d 2023-08-04 jrmu ;; ;; (let ((x 5))
992 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
993 665c255d 2023-08-04 jrmu ;; ;; (* x x)))
996 665c255d 2023-08-04 jrmu ;; ;; (test-eval
997 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 3))
998 665c255d 2023-08-04 jrmu ;; ;; (let ((x 5))
999 665c255d 2023-08-04 jrmu ;; ;; (define y x)
1000 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
1001 665c255d 2023-08-04 jrmu ;; ;; (* y x)))
1004 665c255d 2023-08-04 jrmu ;; ;; (test-eval
1005 665c255d 2023-08-04 jrmu ;; ;; '(let ((y -1) (x 3))
1006 665c255d 2023-08-04 jrmu ;; ;; (let ((y 0.5) (x 5))
1007 665c255d 2023-08-04 jrmu ;; ;; (define a x)
1008 665c255d 2023-08-04 jrmu ;; ;; (define b y)
1009 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
1010 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! y)
1011 665c255d 2023-08-04 jrmu ;; ;; (* a b x y)))
1012 665c255d 2023-08-04 jrmu ;; ;; (* 5 3 -1 0.5))
1014 665c255d 2023-08-04 jrmu ;; ;; (test-eval
1015 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 3) (y 4))
1016 665c255d 2023-08-04 jrmu ;; ;; (let ((x 5))
1017 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
1018 665c255d 2023-08-04 jrmu ;; ;; (+ x 4)))
1021 665c255d 2023-08-04 jrmu ;; ;; (test-eval
1022 665c255d 2023-08-04 jrmu ;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
1023 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! b)
1024 665c255d 2023-08-04 jrmu ;; ;; (+ a c d))
1025 665c255d 2023-08-04 jrmu ;; ;; (+ 1 3 4))
1027 665c255d 2023-08-04 jrmu ;; ;; (test-eval
1028 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 4) (y 5))
1029 665c255d 2023-08-04 jrmu ;; ;; (let ((a 1) (b 2) (c 3))
1030 665c255d 2023-08-04 jrmu ;; ;; (let ((x (+ a b)) (y (+ c a)))
1031 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
1032 665c255d 2023-08-04 jrmu ;; ;; (let ((a x) (b (+ x y)))
1033 665c255d 2023-08-04 jrmu ;; ;; (define z b)
1034 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! b)
1035 665c255d 2023-08-04 jrmu ;; ;; (* (+ a z)
1036 665c255d 2023-08-04 jrmu ;; ;; (+ a b y))))))
1037 665c255d 2023-08-04 jrmu ;; ;; (* (+ 4 8)
1038 665c255d 2023-08-04 jrmu ;; ;; (+ 4 2 4)))
1040 665c255d 2023-08-04 jrmu ;; ;; x 3 -- y 4
1041 665c255d 2023-08-04 jrmu ;; ;; x 4 -- y 4
1042 665c255d 2023-08-04 jrmu ;; ;; a 4 -- b 4
1043 665c255d 2023-08-04 jrmu ;; ;; a 4 -- b 2
1045 665c255d 2023-08-04 jrmu ;; ;; scan-out-defines
1048 665c255d 2023-08-04 jrmu ;; '(define (f x)
1049 665c255d 2023-08-04 jrmu ;; (define (even? n)
1050 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1052 665c255d 2023-08-04 jrmu ;; (odd? (- n 1))))
1053 665c255d 2023-08-04 jrmu ;; (define (odd? n)
1054 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1056 665c255d 2023-08-04 jrmu ;; (even? (- n 1))))
1057 665c255d 2023-08-04 jrmu ;; (even? x)))
1058 665c255d 2023-08-04 jrmu ;; (test-eval '(f 5) false)
1059 665c255d 2023-08-04 jrmu ;; (test-eval '(f 10) true)
1061 665c255d 2023-08-04 jrmu ;; ;; (geval
1062 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 5))
1063 665c255d 2023-08-04 jrmu ;; ;; (define y x)
1064 665c255d 2023-08-04 jrmu ;; ;; (define x 3)
1065 665c255d 2023-08-04 jrmu ;; ;; (+ x y)))
1066 665c255d 2023-08-04 jrmu ;; ;; signal an error because x is undefined if variables are scanned out
1068 665c255d 2023-08-04 jrmu ;; ;; letrec
1071 665c255d 2023-08-04 jrmu ;; '(define (f x)
1072 665c255d 2023-08-04 jrmu ;; (letrec ((even?
1073 665c255d 2023-08-04 jrmu ;; (lambda (n)
1074 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1076 665c255d 2023-08-04 jrmu ;; (odd? (- n 1)))))
1078 665c255d 2023-08-04 jrmu ;; (lambda (n)
1079 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1081 665c255d 2023-08-04 jrmu ;; (even? (- n 1))))))
1082 665c255d 2023-08-04 jrmu ;; (even? x))))
1083 665c255d 2023-08-04 jrmu ;; (test-eval '(f 11) false)
1084 665c255d 2023-08-04 jrmu ;; (test-eval '(f 16) true)
1086 665c255d 2023-08-04 jrmu ;; (test-eval
1087 665c255d 2023-08-04 jrmu ;; '(letrec ((fact
1088 665c255d 2023-08-04 jrmu ;; (lambda (n)
1089 665c255d 2023-08-04 jrmu ;; (if (= n 1)
1091 665c255d 2023-08-04 jrmu ;; (* n (fact (- n 1)))))))
1092 665c255d 2023-08-04 jrmu ;; (fact 10))
1093 665c255d 2023-08-04 jrmu ;; 3628800)
1096 665c255d 2023-08-04 jrmu (geval '(define (require p) (if (not p) (amb))))
1098 665c255d 2023-08-04 jrmu ;; (test-eval '(amb 1 2 3) 1)
1099 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 2)
1100 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 3)
1101 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again "No alternatives")
1102 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again "No current problem")
1103 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again "No current problem")
1104 665c255d 2023-08-04 jrmu ;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
1106 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 2)
1107 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 'a)
1108 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 'b)
1109 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again "No alternatives")
1110 665c255d 2023-08-04 jrmu ;; (test-eval '(require false) "No alternatives")
1111 665c255d 2023-08-04 jrmu ;; (test-eval '(require true) false)
1115 665c255d 2023-08-04 jrmu '(define (an-integer-between low high)
1116 665c255d 2023-08-04 jrmu (require (<= low high))
1117 665c255d 2023-08-04 jrmu (amb low (an-integer-between (+ low 1) high))))
1120 665c255d 2023-08-04 jrmu '(define (a-pythagorean-triple-between low high)
1121 665c255d 2023-08-04 jrmu (let ((i (an-integer-between low high)))
1122 665c255d 2023-08-04 jrmu (let ((j (an-integer-between i high)))
1123 665c255d 2023-08-04 jrmu (let ((k (an-integer-between j high)))
1124 665c255d 2023-08-04 jrmu (require (= (+ (* i i) (* j j)) (* k k)))
1125 665c255d 2023-08-04 jrmu (list i j k))))))
1127 665c255d 2023-08-04 jrmu ;; (test-eval
1128 665c255d 2023-08-04 jrmu ;; '(a-pythagorean-triple-between 1 20)
1129 665c255d 2023-08-04 jrmu ;; '(3 4 5))
1130 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(5 12 13))
1131 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(6 8 10))
1132 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(8 15 17))
1133 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(9 12 15))
1136 665c255d 2023-08-04 jrmu '(define (an-integer-starting-from low)
1137 665c255d 2023-08-04 jrmu (amb low (an-integer-starting-from (+ low 1)))))
1140 665c255d 2023-08-04 jrmu '(define (pythagorean-triples-starting-from low)
1141 665c255d 2023-08-04 jrmu (let* ((k (an-integer-starting-from low))
1142 665c255d 2023-08-04 jrmu (i (an-integer-between low k))
1143 665c255d 2023-08-04 jrmu (j (an-integer-between i k)))
1144 665c255d 2023-08-04 jrmu (require (= (+ (* i i) (* j j)) (* k k)))
1145 665c255d 2023-08-04 jrmu (list i j k))))
1147 665c255d 2023-08-04 jrmu ;; (test-eval '(pythagorean-triples-starting-from 1)
1148 665c255d 2023-08-04 jrmu ;; '(3 4 5))
1149 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(6 8 10))
1150 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(5 12 13))
1151 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(9 12 15))
1152 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(8 15 17))
1155 665c255d 2023-08-04 jrmu '(define (next-triplet trp)
1156 665c255d 2023-08-04 jrmu (let ((i (car trp))
1157 665c255d 2023-08-04 jrmu (j (cadr trp))
1158 665c255d 2023-08-04 jrmu (k (caddr trp)))
1159 665c255d 2023-08-04 jrmu (cond ((= i j k) (list 1 1 (+ k 1)))
1160 665c255d 2023-08-04 jrmu ((= j k) (list (+ i 1) (+ i 1) k))
1161 665c255d 2023-08-04 jrmu (else (list i (+ j 1) k))))))
1163 665c255d 2023-08-04 jrmu '(define (triplet-starting-from trp)
1164 665c255d 2023-08-04 jrmu (amb trp (triplet-starting-from (next-triplet trp)))))
1166 665c255d 2023-08-04 jrmu '(define (pythagorean-triples-starting-from low)
1167 665c255d 2023-08-04 jrmu (let* ((triplet (triplet-starting-from (list low low low)))
1168 665c255d 2023-08-04 jrmu (i (car triplet))
1169 665c255d 2023-08-04 jrmu (j (cadr triplet))
1170 665c255d 2023-08-04 jrmu (k (caddr triplet)))
1171 665c255d 2023-08-04 jrmu (require (= (+ (* i i) (* j j)) (* k k)))
1172 665c255d 2023-08-04 jrmu (list i j k))))
1174 665c255d 2023-08-04 jrmu '(define (distinct? items)
1175 665c255d 2023-08-04 jrmu (cond ((null? items) true)
1176 665c255d 2023-08-04 jrmu ((null? (cdr items)) true)
1177 665c255d 2023-08-04 jrmu ((member (car items) (cdr items)) false)
1178 665c255d 2023-08-04 jrmu (else (distinct? (cdr items))))))
1181 665c255d 2023-08-04 jrmu '(define nouns '(noun student professor cat class)))
1183 665c255d 2023-08-04 jrmu '(define verbs '(verb studies lectures eats sleeps)))
1185 665c255d 2023-08-04 jrmu '(define articles '(article the a)))
1187 665c255d 2023-08-04 jrmu '(define prepositions '(prep for to in by with)))
1190 665c255d 2023-08-04 jrmu '(define (parse-sentence)
1191 665c255d 2023-08-04 jrmu (list 'sentence
1192 665c255d 2023-08-04 jrmu (parse-noun-phrase)
1193 665c255d 2023-08-04 jrmu (parse-verb-phrase))))
1195 665c255d 2023-08-04 jrmu '(define (parse-verb-phrase)
1196 665c255d 2023-08-04 jrmu (define (maybe-extend verb-phrase)
1197 665c255d 2023-08-04 jrmu (ramb verb-phrase
1198 665c255d 2023-08-04 jrmu (maybe-extend
1199 665c255d 2023-08-04 jrmu (list 'verb-phrase
1200 665c255d 2023-08-04 jrmu verb-phrase
1201 665c255d 2023-08-04 jrmu (parse-prepositional-phrase)))))
1202 665c255d 2023-08-04 jrmu (maybe-extend (parse-word verbs))))
1204 665c255d 2023-08-04 jrmu '(define (parse-simple-noun-phrase)
1205 665c255d 2023-08-04 jrmu (list 'simple-noun-phrase
1206 665c255d 2023-08-04 jrmu (parse-word articles)
1207 665c255d 2023-08-04 jrmu (parse-word nouns))))
1209 665c255d 2023-08-04 jrmu '(define (parse-noun-phrase)
1210 665c255d 2023-08-04 jrmu (define (maybe-extend noun-phrase)
1211 665c255d 2023-08-04 jrmu (ramb noun-phrase
1212 665c255d 2023-08-04 jrmu (maybe-extend
1213 665c255d 2023-08-04 jrmu (list 'noun-phrase
1214 665c255d 2023-08-04 jrmu noun-phrase
1215 665c255d 2023-08-04 jrmu (parse-prepositional-phrase)))))
1216 665c255d 2023-08-04 jrmu (maybe-extend (parse-simple-noun-phrase))))
1218 665c255d 2023-08-04 jrmu '(define (parse-prepositional-phrase)
1219 665c255d 2023-08-04 jrmu (list 'prep-phrase
1220 665c255d 2023-08-04 jrmu (parse-word prepositions)
1221 665c255d 2023-08-04 jrmu (parse-noun-phrase))))
1223 665c255d 2023-08-04 jrmu '(define *unparsed* '()))
1225 665c255d 2023-08-04 jrmu '(define (parse input)
1226 665c255d 2023-08-04 jrmu (set! *unparsed* input)
1227 665c255d 2023-08-04 jrmu (let ((sent (parse-sentence)))
1228 665c255d 2023-08-04 jrmu (require (null? *unparsed*))
1231 665c255d 2023-08-04 jrmu ;; Exercise 4.49. Alyssa P. Hacker is more interested in generating interesting sentences than in parsing them. She reasons that by simply changing the procedure parse-word so that it ignores the ``input sentence'' and instead always succeeds and generates an appropriate word, we can use the programs we had built for parsing to do generation instead. Implement Alyssa's idea, and show the first half-dozen or so sentences generated.54
1234 665c255d 2023-08-04 jrmu '(define (an-element-of items)
1235 665c255d 2023-08-04 jrmu (require (not (null? items)))
1236 665c255d 2023-08-04 jrmu (ramb (car items) (an-element-of (cdr items)))))
1239 665c255d 2023-08-04 jrmu '(define (parse-word word-list)
1240 665c255d 2023-08-04 jrmu (let ((found-word (an-element-of (cdr word-list))))
1241 665c255d 2023-08-04 jrmu (set! *unparsed* (append *unparsed* (list found-word)))
1242 665c255d 2023-08-04 jrmu (list (car word-list) found-word))))
1244 665c255d 2023-08-04 jrmu (print-eval '(parse-sentence))
1245 665c255d 2023-08-04 jrmu (print-eval 'try-again)
1246 665c255d 2023-08-04 jrmu (print-eval 'try-again)
1247 665c255d 2023-08-04 jrmu (print-eval 'try-again)
1248 665c255d 2023-08-04 jrmu (print-eval 'try-again)
1249 665c255d 2023-08-04 jrmu (print-eval 'try-again)
1250 665c255d 2023-08-04 jrmu (print-eval 'try-again)
1252 665c255d 2023-08-04 jrmu ;; Exercise 4.50. Implement a new special form ramb that is like amb except that it searches alternatives in a random order, rather than from left to right. Show how this can help with Alyssa's problem in exercise 4.49.
1254 665c255d 2023-08-04 jrmu ;; (ramb <choice1> <choice2> ... <choiceN>)
1256 665c255d 2023-08-04 jrmu ;; ;; once a choice has been tried, we remove it so that
1257 665c255d 2023-08-04 jrmu ;; ;; eventually, the failure continuation can be called
1258 665c255d 2023-08-04 jrmu ;; (define (analyze-ramb exp)
1259 665c255d 2023-08-04 jrmu ;; (let ((cprocs (shufle (map analyze (amb-choices)))))
1260 665c255d 2023-08-04 jrmu ;; (lambda (env succeed fail)
1261 665c255d 2023-08-04 jrmu ;; (define (try-next choices)
1262 665c255d 2023-08-04 jrmu ;; (if (null? choices)
1264 665c255d 2023-08-04 jrmu ;; ((car choices)
1266 665c255d 2023-08-04 jrmu ;; succeed
1267 665c255d 2023-08-04 jrmu ;; (lambda ()
1268 665c255d 2023-08-04 jrmu ;; (try-next (cdr choices))))))
1269 665c255d 2023-08-04 jrmu ;; (try-next cprocs))))
1271 665c255d 2023-08-04 jrmu ;; in fact, we can just use shuffle to perform a syntactic transformation
