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 ((application? exp) (analyze-application exp))
26 665c255d 2023-08-04 jrmu (error "Unknown expression type -- ANALYZE" exp))))
29 665c255d 2023-08-04 jrmu ;; analyzing procedures
30 665c255d 2023-08-04 jrmu (define (analyze-self-evaluating exp)
31 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
32 665c255d 2023-08-04 jrmu (succeed exp fail)))
33 665c255d 2023-08-04 jrmu (define (analyze-quoted exp)
34 665c255d 2023-08-04 jrmu (let ((qval (text-of-quotation exp)))
35 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
36 665c255d 2023-08-04 jrmu (succeed qval fail))))
37 665c255d 2023-08-04 jrmu (define (analyze-variable exp)
38 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
39 665c255d 2023-08-04 jrmu (succeed (lookup-variable-value exp env)
41 665c255d 2023-08-04 jrmu (define (analyze-lambda exp)
42 665c255d 2023-08-04 jrmu (let ((vars (lambda-parameters exp))
43 665c255d 2023-08-04 jrmu (bproc (analyze-sequence (scan-out-defines (lambda-body exp)))))
44 665c255d 2023-08-04 jrmu ;; (bproc (analyze-sequence (lambda-body exp))))
45 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
46 665c255d 2023-08-04 jrmu (succeed (make-procedure vars bproc env)
48 665c255d 2023-08-04 jrmu (define (analyze-if exp)
49 665c255d 2023-08-04 jrmu (let ((pproc (analyze (if-predicate exp)))
50 665c255d 2023-08-04 jrmu (cproc (analyze (if-consequent exp)))
51 665c255d 2023-08-04 jrmu (aproc (analyze (if-alternative exp))))
52 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
54 665c255d 2023-08-04 jrmu ;; success continuation for evaluating the predicate
55 665c255d 2023-08-04 jrmu ;; to obtain pred-value
56 665c255d 2023-08-04 jrmu (lambda (pred-value fail2)
57 665c255d 2023-08-04 jrmu (if (true? pred-value)
58 665c255d 2023-08-04 jrmu (cproc env succeed fail2)
59 665c255d 2023-08-04 jrmu (aproc env succeed fail2)))
60 665c255d 2023-08-04 jrmu ;; failure continuation for evaluating the predicate
62 665c255d 2023-08-04 jrmu (define (analyze-sequence exps)
63 665c255d 2023-08-04 jrmu (define (sequentially a b)
64 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
66 665c255d 2023-08-04 jrmu ;; success continuation for calling a
67 665c255d 2023-08-04 jrmu (lambda (a-value fail2)
68 665c255d 2023-08-04 jrmu (b env succeed fail2))
69 665c255d 2023-08-04 jrmu ;; failure continuation for calling a
71 665c255d 2023-08-04 jrmu (define (loop first-proc rest-procs)
72 665c255d 2023-08-04 jrmu (if (null? rest-procs)
74 665c255d 2023-08-04 jrmu (loop (sequentially first-proc (car rest-procs))
75 665c255d 2023-08-04 jrmu (cdr rest-procs))))
76 665c255d 2023-08-04 jrmu (let ((procs (map analyze exps)))
77 665c255d 2023-08-04 jrmu (if (null? procs)
78 665c255d 2023-08-04 jrmu (error "Empty sequence -- ANALYZE"))
79 665c255d 2023-08-04 jrmu (loop (car procs) (cdr procs))))
80 665c255d 2023-08-04 jrmu (define (analyze-definition exp)
81 665c255d 2023-08-04 jrmu (let ((var (definition-variable exp))
82 665c255d 2023-08-04 jrmu (vproc (analyze (definition-value exp))))
83 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
85 665c255d 2023-08-04 jrmu (lambda (val fail2)
86 665c255d 2023-08-04 jrmu (define-variable! var val env)
87 665c255d 2023-08-04 jrmu (succeed 'ok fail2))
89 665c255d 2023-08-04 jrmu (define (analyze-assignment exp)
90 665c255d 2023-08-04 jrmu (let ((var (assignment-variable exp))
91 665c255d 2023-08-04 jrmu (vproc (analyze (assignment-value exp))))
92 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
94 665c255d 2023-08-04 jrmu (lambda (val fail2) ; *1*
95 665c255d 2023-08-04 jrmu (let ((old-value
96 665c255d 2023-08-04 jrmu (lookup-variable-value var env)))
97 665c255d 2023-08-04 jrmu (set-variable-value! var val env)
98 665c255d 2023-08-04 jrmu (succeed 'ok
99 665c255d 2023-08-04 jrmu (lambda () ; *2*
100 665c255d 2023-08-04 jrmu (set-variable-value! var
103 665c255d 2023-08-04 jrmu (fail2)))))
106 665c255d 2023-08-04 jrmu (define (analyze-application exp)
107 665c255d 2023-08-04 jrmu (let ((fproc (analyze (operator exp)))
108 665c255d 2023-08-04 jrmu (aprocs (map analyze (operands exp))))
109 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
111 665c255d 2023-08-04 jrmu (lambda (proc fail2)
112 665c255d 2023-08-04 jrmu (get-args aprocs
114 665c255d 2023-08-04 jrmu (lambda (args fail3)
115 665c255d 2023-08-04 jrmu (execute-application
116 665c255d 2023-08-04 jrmu proc args succeed fail3))
119 665c255d 2023-08-04 jrmu (define (get-args aprocs env succeed fail)
120 665c255d 2023-08-04 jrmu (if (null? aprocs)
121 665c255d 2023-08-04 jrmu (succeed '() fail)
122 665c255d 2023-08-04 jrmu ((car aprocs) env
123 665c255d 2023-08-04 jrmu ;; success continuation for this aproc
124 665c255d 2023-08-04 jrmu (lambda (arg fail2)
125 665c255d 2023-08-04 jrmu (get-args (cdr aprocs)
127 665c255d 2023-08-04 jrmu ;; success continuation for recursive
128 665c255d 2023-08-04 jrmu ;; call to get-args
129 665c255d 2023-08-04 jrmu (lambda (args fail3)
130 665c255d 2023-08-04 jrmu (succeed (cons arg args)
135 665c255d 2023-08-04 jrmu (define (analyze-amb exp)
136 665c255d 2023-08-04 jrmu (let ((cprocs (map analyze (amb-choices exp))))
137 665c255d 2023-08-04 jrmu (lambda (env succeed fail)
138 665c255d 2023-08-04 jrmu (define (try-next choices)
139 665c255d 2023-08-04 jrmu (if (null? choices)
141 665c255d 2023-08-04 jrmu ((car choices) env
144 665c255d 2023-08-04 jrmu (try-next (cdr choices))))))
145 665c255d 2023-08-04 jrmu (try-next cprocs))))
152 665c255d 2023-08-04 jrmu (define (tagged-list? exp tag)
153 665c255d 2023-08-04 jrmu (if (pair? exp)
154 665c255d 2023-08-04 jrmu (eq? (car exp) tag)
158 665c255d 2023-08-04 jrmu (define (amb? exp) (tagged-list? exp 'amb))
159 665c255d 2023-08-04 jrmu (define (amb-choices exp) (cdr exp))
161 665c255d 2023-08-04 jrmu ;; self-evaluating/variable/quoted
162 665c255d 2023-08-04 jrmu (define (self-evaluating? exp)
163 665c255d 2023-08-04 jrmu (cond ((number? exp) true)
164 665c255d 2023-08-04 jrmu ((string? exp) true)
165 665c255d 2023-08-04 jrmu (else false)))
166 665c255d 2023-08-04 jrmu (define (variable? exp) (symbol? exp))
167 665c255d 2023-08-04 jrmu (define (quoted? exp)
168 665c255d 2023-08-04 jrmu (tagged-list? exp 'quote))
169 665c255d 2023-08-04 jrmu (define (text-of-quotation exp) (cadr exp))
171 665c255d 2023-08-04 jrmu ;; assignment/definition
172 665c255d 2023-08-04 jrmu (define (assignment? exp)
173 665c255d 2023-08-04 jrmu (tagged-list? exp 'set!))
174 665c255d 2023-08-04 jrmu (define (assignment-variable exp) (cadr exp))
175 665c255d 2023-08-04 jrmu (define (assignment-value exp) (caddr exp))
176 665c255d 2023-08-04 jrmu (define (make-assignment var val)
177 665c255d 2023-08-04 jrmu (list 'set! var val))
178 665c255d 2023-08-04 jrmu (define (definition? exp)
179 665c255d 2023-08-04 jrmu (tagged-list? exp 'define))
180 665c255d 2023-08-04 jrmu (define (definition-variable exp)
181 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
183 665c255d 2023-08-04 jrmu (caadr exp)))
184 665c255d 2023-08-04 jrmu (define (definition-value exp)
185 665c255d 2023-08-04 jrmu (if (symbol? (cadr exp))
186 665c255d 2023-08-04 jrmu (caddr exp)
187 665c255d 2023-08-04 jrmu (make-lambda (cdadr exp) ; formal parameters
188 665c255d 2023-08-04 jrmu (cddr exp)))) ; body
189 665c255d 2023-08-04 jrmu (define (make-definition var val)
190 665c255d 2023-08-04 jrmu `(define ,var ,val))
192 665c255d 2023-08-04 jrmu ;; if/and/or/not/xor
193 665c255d 2023-08-04 jrmu (define (if? exp) (tagged-list? exp 'if))
194 665c255d 2023-08-04 jrmu (define (if-predicate exp) (cadr exp))
195 665c255d 2023-08-04 jrmu (define (if-consequent exp) (caddr exp))
196 665c255d 2023-08-04 jrmu (define (if-alternative exp)
197 665c255d 2023-08-04 jrmu (if (not (null? (cdddr exp)))
198 665c255d 2023-08-04 jrmu (cadddr exp)
200 665c255d 2023-08-04 jrmu (define (make-if predicate consequent alternative)
201 665c255d 2023-08-04 jrmu (list 'if predicate consequent alternative))
203 665c255d 2023-08-04 jrmu (define (and? exp)
204 665c255d 2023-08-04 jrmu (tagged-list? exp 'and))
205 665c255d 2023-08-04 jrmu (define (and-clauses exp)
207 665c255d 2023-08-04 jrmu (define (or? exp)
208 665c255d 2023-08-04 jrmu (tagged-list? exp 'or))
209 665c255d 2023-08-04 jrmu (define (or-clauses exp)
211 665c255d 2023-08-04 jrmu (define (and->if exp)
212 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
213 665c255d 2023-08-04 jrmu (cond ((null? clauses) 'true)
214 665c255d 2023-08-04 jrmu ((null? (cdr clauses)) (car clauses))
215 665c255d 2023-08-04 jrmu (else (make-if (car clauses)
216 665c255d 2023-08-04 jrmu (expand-clauses (cdr clauses))
218 665c255d 2023-08-04 jrmu (expand-clauses (and-clauses exp)))
219 665c255d 2023-08-04 jrmu (define (or->if exp)
220 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
221 665c255d 2023-08-04 jrmu (if (null? clauses)
223 665c255d 2023-08-04 jrmu (make-if (car clauses)
224 665c255d 2023-08-04 jrmu (car clauses)
225 665c255d 2023-08-04 jrmu (expand-clauses (cdr clauses)))))
226 665c255d 2023-08-04 jrmu (expand-clauses (or-clauses exp)))
227 665c255d 2023-08-04 jrmu (define (not? exp)
228 665c255d 2023-08-04 jrmu (tagged-list? exp 'not))
229 665c255d 2023-08-04 jrmu (define (not->if exp)
230 665c255d 2023-08-04 jrmu `(if ,(cadr exp) false true))
231 665c255d 2023-08-04 jrmu (define (xor? exp)
232 665c255d 2023-08-04 jrmu (tagged-list? exp 'xor))
233 665c255d 2023-08-04 jrmu (define (xor->or-and-not exp)
234 665c255d 2023-08-04 jrmu (let ((pred-1 (cadr exp))
235 665c255d 2023-08-04 jrmu (pred-2 (caddr exp)))
236 665c255d 2023-08-04 jrmu `(or (and ,pred-1 (not ,pred-2))
237 665c255d 2023-08-04 jrmu (and (not ,pred-1) ,pred-2))))
239 665c255d 2023-08-04 jrmu ;; lambda/let/let*/letrec
240 665c255d 2023-08-04 jrmu (define (lambda? exp) (tagged-list? exp 'lambda))
241 665c255d 2023-08-04 jrmu (define (lambda-parameters exp) (cadr exp))
242 665c255d 2023-08-04 jrmu (define (lambda-body exp) (cddr exp))
243 665c255d 2023-08-04 jrmu (define (make-lambda parameters body)
244 665c255d 2023-08-04 jrmu (cons 'lambda (cons parameters body)))
246 665c255d 2023-08-04 jrmu (define (make-let vars vals body)
248 665c255d 2023-08-04 jrmu (cons (map list vars vals)
250 665c255d 2023-08-04 jrmu (define (let? exp)
251 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
252 665c255d 2023-08-04 jrmu (not (symbol? (cadr exp)))))
253 665c255d 2023-08-04 jrmu (define (let-vars exp)
254 665c255d 2023-08-04 jrmu (map car (cadr exp)))
255 665c255d 2023-08-04 jrmu (define (let-vals exp)
256 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
257 665c255d 2023-08-04 jrmu (define (let-body exp)
258 665c255d 2023-08-04 jrmu (cddr exp))
259 665c255d 2023-08-04 jrmu (define (let->combination exp)
260 665c255d 2023-08-04 jrmu (make-application (make-lambda (let-vars exp) (let-body exp))
261 665c255d 2023-08-04 jrmu (let-vals exp)))
262 665c255d 2023-08-04 jrmu (define (named-let? exp)
263 665c255d 2023-08-04 jrmu (and (tagged-list? exp 'let)
264 665c255d 2023-08-04 jrmu v (symbol? (cadr exp))))
265 665c255d 2023-08-04 jrmu (define (named-let-name exp)
266 665c255d 2023-08-04 jrmu (cadr exp))
267 665c255d 2023-08-04 jrmu (define (named-let-vars exp)
268 665c255d 2023-08-04 jrmu (map car (caddr exp)))
269 665c255d 2023-08-04 jrmu (define (named-let-vals exp)
270 665c255d 2023-08-04 jrmu (map cadr (caddr exp)))
271 665c255d 2023-08-04 jrmu (define (named-let-body exp)
272 665c255d 2023-08-04 jrmu (cdddr exp))
273 665c255d 2023-08-04 jrmu (define (named-let->combination exp)
274 665c255d 2023-08-04 jrmu (sequence->exp
275 665c255d 2023-08-04 jrmu (list (make-definition (named-let-name exp)
276 665c255d 2023-08-04 jrmu (make-lambda (named-let-vars exp)
277 665c255d 2023-08-04 jrmu (named-let-body exp)))
278 665c255d 2023-08-04 jrmu (make-application (named-let-name exp)
279 665c255d 2023-08-04 jrmu (named-let-vals exp)))))
280 665c255d 2023-08-04 jrmu (define (make-named-let name vars vals body)
283 665c255d 2023-08-04 jrmu (cons (map list vars vals)
286 665c255d 2023-08-04 jrmu (define (letrec? exp)
287 665c255d 2023-08-04 jrmu (tagged-list? exp 'letrec))
289 665c255d 2023-08-04 jrmu (define (letrec-vars exp)
290 665c255d 2023-08-04 jrmu (map car (cadr exp)))
291 665c255d 2023-08-04 jrmu (define (letrec-vals exp)
292 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
293 665c255d 2023-08-04 jrmu (define (letrec-body exp)
294 665c255d 2023-08-04 jrmu (cddr exp))
295 665c255d 2023-08-04 jrmu (define (letrec->let exp)
296 665c255d 2023-08-04 jrmu (let* ((vars (letrec-vars exp))
297 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
299 665c255d 2023-08-04 jrmu (vals (letrec-vals exp))
300 665c255d 2023-08-04 jrmu (assignments (map (lambda (var val)
301 665c255d 2023-08-04 jrmu (make-assignment var val))
304 665c255d 2023-08-04 jrmu (body (letrec-body exp)))
305 665c255d 2023-08-04 jrmu (make-let vars
306 665c255d 2023-08-04 jrmu unassigneds
307 665c255d 2023-08-04 jrmu (append assignments body))))
309 665c255d 2023-08-04 jrmu (define (make-application op args)
310 665c255d 2023-08-04 jrmu (cons op args))
312 665c255d 2023-08-04 jrmu (define (let*? exp)
313 665c255d 2023-08-04 jrmu (tagged-list? exp 'let*))
314 665c255d 2023-08-04 jrmu (define let*-vars let-vars)
315 665c255d 2023-08-04 jrmu (define let*-vals let-vals)
316 665c255d 2023-08-04 jrmu (define let*-body let-body)
317 665c255d 2023-08-04 jrmu (define (let*->nested-lets exp)
318 665c255d 2023-08-04 jrmu (define (expand-lets vars vals)
319 665c255d 2023-08-04 jrmu (if (null? (cdr vars))
320 665c255d 2023-08-04 jrmu (make-let (list (car vars))
321 665c255d 2023-08-04 jrmu (list (car vals))
322 665c255d 2023-08-04 jrmu (let*-body exp))
323 665c255d 2023-08-04 jrmu (make-let (list (car vars))
324 665c255d 2023-08-04 jrmu (list (car vals))
325 665c255d 2023-08-04 jrmu (list (expand-lets (cdr vars) (cdr vals))))))
326 665c255d 2023-08-04 jrmu (let ((vars (let*-vars exp))
327 665c255d 2023-08-04 jrmu (vals (let*-vals exp)))
328 665c255d 2023-08-04 jrmu (if (null? vars)
329 665c255d 2023-08-04 jrmu (sequence->exp (let*-body exp))
330 665c255d 2023-08-04 jrmu (expand-lets vars vals))))
333 665c255d 2023-08-04 jrmu (define (do? exp)
334 665c255d 2023-08-04 jrmu (tagged-list? exp 'do))
335 665c255d 2023-08-04 jrmu (define (do-vars exp)
336 665c255d 2023-08-04 jrmu (map car (cadr exp)))
337 665c255d 2023-08-04 jrmu (define (do-inits exp)
338 665c255d 2023-08-04 jrmu (map cadr (cadr exp)))
339 665c255d 2023-08-04 jrmu (define (do-steps exp)
340 665c255d 2023-08-04 jrmu (map (lambda (var-init-step)
341 665c255d 2023-08-04 jrmu (if (null? (cddr var-init-step))
342 665c255d 2023-08-04 jrmu (car var-init-step)
343 665c255d 2023-08-04 jrmu (caddr var-init-step)))
344 665c255d 2023-08-04 jrmu (cadr exp)))
345 665c255d 2023-08-04 jrmu (define (do-test exp)
346 665c255d 2023-08-04 jrmu (caaddr exp))
347 665c255d 2023-08-04 jrmu (define (do-expressions exp)
348 665c255d 2023-08-04 jrmu (if (null? (cdaddr exp))
349 665c255d 2023-08-04 jrmu (caddr exp)
350 665c255d 2023-08-04 jrmu (cdaddr exp)))
351 665c255d 2023-08-04 jrmu (define (do-commands exp)
352 665c255d 2023-08-04 jrmu (cdddr exp))
353 665c255d 2023-08-04 jrmu (define (do->combination exp)
354 665c255d 2023-08-04 jrmu (make-named-let
356 665c255d 2023-08-04 jrmu (do-vars exp)
357 665c255d 2023-08-04 jrmu (do-inits exp)
360 665c255d 2023-08-04 jrmu (do-test exp)
361 665c255d 2023-08-04 jrmu (sequence->exp (do-expressions exp))
362 665c255d 2023-08-04 jrmu (sequence->exp
363 665c255d 2023-08-04 jrmu (append (do-commands exp)
364 665c255d 2023-08-04 jrmu (list (make-application
366 665c255d 2023-08-04 jrmu (do-steps exp)))))))))
369 665c255d 2023-08-04 jrmu ;; begin/sequence
370 665c255d 2023-08-04 jrmu (define (begin? exp) (tagged-list? exp 'begin))
371 665c255d 2023-08-04 jrmu (define (begin-actions exp) (cdr exp))
372 665c255d 2023-08-04 jrmu (define (last-exp? seq) (null? (cdr seq)))
373 665c255d 2023-08-04 jrmu (define (first-exp seq) (car seq))
374 665c255d 2023-08-04 jrmu (define (rest-exps seq) (cdr seq))
375 665c255d 2023-08-04 jrmu (define (sequence->exp seq)
376 665c255d 2023-08-04 jrmu (cond ((null? seq) seq)
377 665c255d 2023-08-04 jrmu ((last-exp? seq) (first-exp seq))
378 665c255d 2023-08-04 jrmu (else (make-begin seq))))
379 665c255d 2023-08-04 jrmu (define (make-begin seq) (cons 'begin seq))
381 665c255d 2023-08-04 jrmu ;; application
382 665c255d 2023-08-04 jrmu (define (application? exp) (pair? exp))
383 665c255d 2023-08-04 jrmu (define (operator exp) (car exp))
384 665c255d 2023-08-04 jrmu (define (operands exp) (cdr exp))
385 665c255d 2023-08-04 jrmu (define (no-operands? ops) (null? ops))
386 665c255d 2023-08-04 jrmu (define (first-operand ops) (car ops))
387 665c255d 2023-08-04 jrmu (define (rest-operands ops) (cdr ops))
390 665c255d 2023-08-04 jrmu (define (cond? exp) (tagged-list? exp 'cond))
391 665c255d 2023-08-04 jrmu (define (cond-clauses exp) (cdr exp))
392 665c255d 2023-08-04 jrmu (define (cond-else-clause? clause)
393 665c255d 2023-08-04 jrmu (eq? (cond-predicate clause) 'else))
394 665c255d 2023-08-04 jrmu (define (cond-predicate clause) (car clause))
395 665c255d 2023-08-04 jrmu (define (cond-actions clause) (cdr clause))
396 665c255d 2023-08-04 jrmu (define (cond-extended-clause? clause)
397 665c255d 2023-08-04 jrmu (and (not (null? (cdr clause))) (eq? (cadr clause) '=>)))
398 665c255d 2023-08-04 jrmu (define (cond-extended-proc clause)
399 665c255d 2023-08-04 jrmu (caddr clause))
400 665c255d 2023-08-04 jrmu (define (cond->if exp)
401 665c255d 2023-08-04 jrmu (expand-clauses (cond-clauses exp)))
402 665c255d 2023-08-04 jrmu (define (expand-clauses clauses)
403 665c255d 2023-08-04 jrmu (if (null? clauses)
404 665c255d 2023-08-04 jrmu 'false ; no else clause
405 665c255d 2023-08-04 jrmu (let ((first (car clauses))
406 665c255d 2023-08-04 jrmu (rest (cdr clauses)))
407 665c255d 2023-08-04 jrmu (if (cond-else-clause? first)
408 665c255d 2023-08-04 jrmu (if (null? rest)
409 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
410 665c255d 2023-08-04 jrmu (error "ELSE clause isn't last -- COND->IF"
412 665c255d 2023-08-04 jrmu (if (cond-extended-clause? first)
413 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
414 665c255d 2023-08-04 jrmu (make-application
415 665c255d 2023-08-04 jrmu (cond-extended-proc first)
416 665c255d 2023-08-04 jrmu (list (cond-predicate first)))
417 665c255d 2023-08-04 jrmu (expand-clauses rest))
418 665c255d 2023-08-04 jrmu (make-if (cond-predicate first)
419 665c255d 2023-08-04 jrmu (sequence->exp (cond-actions first))
420 665c255d 2023-08-04 jrmu (expand-clauses rest)))))))
421 665c255d 2023-08-04 jrmu (define (true? x)
422 665c255d 2023-08-04 jrmu (not (eq? x false)))
423 665c255d 2023-08-04 jrmu (define (false? x)
424 665c255d 2023-08-04 jrmu (eq? x false))
426 665c255d 2023-08-04 jrmu ;; procedure
427 665c255d 2023-08-04 jrmu (define (make-procedure parameters body env)
428 665c255d 2023-08-04 jrmu (list 'procedure parameters body env))
429 665c255d 2023-08-04 jrmu (define (scan-out-defines body)
430 665c255d 2023-08-04 jrmu (let* ((definitions (filter definition? body))
431 665c255d 2023-08-04 jrmu (vars (map definition-variable definitions))
432 665c255d 2023-08-04 jrmu (unassigneds (map (lambda (var) ''*unassigned*)
434 665c255d 2023-08-04 jrmu (vals (map definition-value definitions))
435 665c255d 2023-08-04 jrmu (assignments
436 665c255d 2023-08-04 jrmu (map (lambda (var val)
437 665c255d 2023-08-04 jrmu (make-assignment var val))
438 665c255d 2023-08-04 jrmu vars vals))
439 665c255d 2023-08-04 jrmu (exps (remove definition? body)))
440 665c255d 2023-08-04 jrmu (if (null? definitions)
443 665c255d 2023-08-04 jrmu (make-let vars
444 665c255d 2023-08-04 jrmu unassigneds
445 665c255d 2023-08-04 jrmu (append assignments exps))))))
446 665c255d 2023-08-04 jrmu (define (compound-procedure? p)
447 665c255d 2023-08-04 jrmu (tagged-list? p 'procedure))
448 665c255d 2023-08-04 jrmu (define (procedure-parameters p) (cadr p))
449 665c255d 2023-08-04 jrmu (define (procedure-body p) (caddr p))
450 665c255d 2023-08-04 jrmu (define (procedure-environment p) (cadddr p))
452 665c255d 2023-08-04 jrmu ;; environment
453 665c255d 2023-08-04 jrmu (define (enclosing-environment env) (cdr env))
454 665c255d 2023-08-04 jrmu (define (first-frame env) (car env))
455 665c255d 2023-08-04 jrmu (define the-empty-environment '())
456 665c255d 2023-08-04 jrmu (define (make-frame variables values)
457 665c255d 2023-08-04 jrmu (cons variables values))
458 665c255d 2023-08-04 jrmu (define (frame-variables frame) (car frame))
459 665c255d 2023-08-04 jrmu (define (frame-values frame) (cdr frame))
460 665c255d 2023-08-04 jrmu (define (add-binding-to-frame! var val frame)
461 665c255d 2023-08-04 jrmu (set-car! frame (cons var (car frame)))
462 665c255d 2023-08-04 jrmu (set-cdr! frame (cons val (cdr frame))))
463 665c255d 2023-08-04 jrmu (define (extend-environment vars vals base-env)
464 665c255d 2023-08-04 jrmu (if (= (length vars) (length vals))
465 665c255d 2023-08-04 jrmu (cons (make-frame vars vals) base-env)
466 665c255d 2023-08-04 jrmu (if (< (length vars) (length vals))
467 665c255d 2023-08-04 jrmu (error "Too many arguments supplied" vars vals)
468 665c255d 2023-08-04 jrmu (error "Too few arguments supplied" vars vals))))
469 665c255d 2023-08-04 jrmu (define (lookup-variable-value var env)
470 665c255d 2023-08-04 jrmu (define (env-loop env)
471 665c255d 2023-08-04 jrmu (define (scan vars vals)
472 665c255d 2023-08-04 jrmu (cond ((null? vars)
473 665c255d 2023-08-04 jrmu (env-loop (enclosing-environment env)))
474 665c255d 2023-08-04 jrmu ((eq? var (car vars))
475 665c255d 2023-08-04 jrmu ;; (let ((val (car vals)))
476 665c255d 2023-08-04 jrmu ;; (if (eq? val '*unassigned*)
477 665c255d 2023-08-04 jrmu ;; (error "Var not yet defined -- LOOKUP-VARIABLE-VALUE" var)
479 665c255d 2023-08-04 jrmu (car vals))
480 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
481 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
482 665c255d 2023-08-04 jrmu (error "Unbound variable" var)
483 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
484 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
485 665c255d 2023-08-04 jrmu (frame-values frame)))))
486 665c255d 2023-08-04 jrmu (env-loop env))
487 665c255d 2023-08-04 jrmu (define (set-variable-value! var val 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 (set-car! vals val))
494 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
495 665c255d 2023-08-04 jrmu (if (eq? env the-empty-environment)
496 665c255d 2023-08-04 jrmu (error "Unbound variable -- SET!" var)
497 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
498 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
499 665c255d 2023-08-04 jrmu (frame-values frame)))))
500 665c255d 2023-08-04 jrmu (env-loop env))
501 665c255d 2023-08-04 jrmu (define (define-variable! var val env)
502 665c255d 2023-08-04 jrmu (let ((frame (first-frame env)))
503 665c255d 2023-08-04 jrmu (define (scan vars vals)
504 665c255d 2023-08-04 jrmu (cond ((null? vars)
505 665c255d 2023-08-04 jrmu (add-binding-to-frame! var val frame))
506 665c255d 2023-08-04 jrmu ((eq? var (car vars))
507 665c255d 2023-08-04 jrmu (set-car! vals val))
508 665c255d 2023-08-04 jrmu (else (scan (cdr vars) (cdr vals)))))
509 665c255d 2023-08-04 jrmu (scan (frame-variables frame)
510 665c255d 2023-08-04 jrmu (frame-values frame))))
512 665c255d 2023-08-04 jrmu ;; (define (remove-binding-from-frame! var frame)
513 665c255d 2023-08-04 jrmu ;; (define (scan vars vals)
514 665c255d 2023-08-04 jrmu ;; (cond ((null? (cdr vars))
515 665c255d 2023-08-04 jrmu ;; (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
516 665c255d 2023-08-04 jrmu ;; ((eq? var (cadr vars))
517 665c255d 2023-08-04 jrmu ;; (set-cdr! vars (cddr vars))
518 665c255d 2023-08-04 jrmu ;; (set-cdr! vals (cddr vals)))
519 665c255d 2023-08-04 jrmu ;; (else (scan (cdr vars) (cdr vals)))))
520 665c255d 2023-08-04 jrmu ;; (let ((vars (frame-variables frame))
521 665c255d 2023-08-04 jrmu ;; (vals (frame-values frame)))
522 665c255d 2023-08-04 jrmu ;; (if (eq? var (car vars))
523 665c255d 2023-08-04 jrmu ;; (begin (set-car! frame (cdr vars))
524 665c255d 2023-08-04 jrmu ;; (set-cdr! frame (cdr vals)))
525 665c255d 2023-08-04 jrmu ;; (scan vars vals))))
527 665c255d 2023-08-04 jrmu ;; primitives
528 665c255d 2023-08-04 jrmu (define (primitive-procedure? proc)
529 665c255d 2023-08-04 jrmu (tagged-list? proc 'primitive))
530 665c255d 2023-08-04 jrmu (define (primitive-implementation proc) (cadr proc))
531 665c255d 2023-08-04 jrmu (define primitive-procedures
532 665c255d 2023-08-04 jrmu (list (list 'car car)
533 665c255d 2023-08-04 jrmu (list 'cdr cdr)
534 665c255d 2023-08-04 jrmu (list 'caar caar)
535 665c255d 2023-08-04 jrmu (list 'cadr cadr)
536 665c255d 2023-08-04 jrmu (list 'cddr cddr)
537 665c255d 2023-08-04 jrmu (list 'caddr caddr)
538 665c255d 2023-08-04 jrmu (list 'cdddr cdddr)
539 665c255d 2023-08-04 jrmu (list 'cons cons)
540 665c255d 2023-08-04 jrmu (list 'list list)
541 665c255d 2023-08-04 jrmu (list 'null? null?)
542 665c255d 2023-08-04 jrmu (list 'pair? pair?)
543 665c255d 2023-08-04 jrmu (list '* *)
544 665c255d 2023-08-04 jrmu (list '/ /)
545 665c255d 2023-08-04 jrmu (list '+ +)
546 665c255d 2023-08-04 jrmu (list '- -)
547 665c255d 2023-08-04 jrmu (list '= =)
548 665c255d 2023-08-04 jrmu (list '< <)
549 665c255d 2023-08-04 jrmu (list '> >)
550 665c255d 2023-08-04 jrmu (list '<= <=)
551 665c255d 2023-08-04 jrmu (list '>= >=)
552 665c255d 2023-08-04 jrmu (list 'abs abs)
553 665c255d 2023-08-04 jrmu (list 'remainder remainder)
554 665c255d 2023-08-04 jrmu (list 'eq? eq?)
555 665c255d 2023-08-04 jrmu (list 'equal? equal?)
556 665c255d 2023-08-04 jrmu (list 'member member)
557 665c255d 2023-08-04 jrmu (list 'memq memq)
558 665c255d 2023-08-04 jrmu (list 'display display)
559 665c255d 2023-08-04 jrmu (list 'error error)))
560 665c255d 2023-08-04 jrmu (define (primitive-procedure-names)
562 665c255d 2023-08-04 jrmu primitive-procedures))
563 665c255d 2023-08-04 jrmu (define (primitive-procedure-objects)
564 665c255d 2023-08-04 jrmu (map (lambda (proc) (list 'primitive (cadr proc)))
565 665c255d 2023-08-04 jrmu primitive-procedures))
566 665c255d 2023-08-04 jrmu (define (apply-primitive-procedure proc args)
568 665c255d 2023-08-04 jrmu (primitive-implementation proc) args))
570 665c255d 2023-08-04 jrmu ;; execute application
572 665c255d 2023-08-04 jrmu (define (execute-application proc args succeed fail)
573 665c255d 2023-08-04 jrmu (cond ((primitive-procedure? proc)
574 665c255d 2023-08-04 jrmu (succeed (apply-primitive-procedure proc args)
576 665c255d 2023-08-04 jrmu ((compound-procedure? proc)
577 665c255d 2023-08-04 jrmu ((procedure-body proc)
578 665c255d 2023-08-04 jrmu (extend-environment (procedure-parameters proc)
580 665c255d 2023-08-04 jrmu (procedure-environment proc))
585 665c255d 2023-08-04 jrmu "Unknown procedure type -- EXECUTE-APPLICATION"
589 665c255d 2023-08-04 jrmu ;; driver-loop
590 665c255d 2023-08-04 jrmu (define (prompt-for-input string)
591 665c255d 2023-08-04 jrmu (newline) (newline) (display string) (newline))
592 665c255d 2023-08-04 jrmu (define (announce-output string)
593 665c255d 2023-08-04 jrmu (newline) (display string) (newline))
594 665c255d 2023-08-04 jrmu (define (user-print object)
595 665c255d 2023-08-04 jrmu (if (compound-procedure? object)
596 665c255d 2023-08-04 jrmu (display (list 'compound-procedure
597 665c255d 2023-08-04 jrmu (procedure-parameters object)
598 665c255d 2023-08-04 jrmu (procedure-body object)
599 665c255d 2023-08-04 jrmu '<procedure-env>))
600 665c255d 2023-08-04 jrmu (display object)))
601 665c255d 2023-08-04 jrmu (define (setup-environment)
602 665c255d 2023-08-04 jrmu (let ((initial-env
603 665c255d 2023-08-04 jrmu (extend-environment (primitive-procedure-names)
604 665c255d 2023-08-04 jrmu (primitive-procedure-objects)
605 665c255d 2023-08-04 jrmu the-empty-environment)))
606 665c255d 2023-08-04 jrmu (define-variable! 'true true initial-env)
607 665c255d 2023-08-04 jrmu (define-variable! 'false false initial-env)
608 665c255d 2023-08-04 jrmu initial-env))
609 665c255d 2023-08-04 jrmu (define the-global-environment (setup-environment))
611 665c255d 2023-08-04 jrmu (define input-prompt ";;; Amb-Eval input:")
612 665c255d 2023-08-04 jrmu (define output-prompt ";;; Amb-Eval value:")
613 665c255d 2023-08-04 jrmu (define (driver-loop)
614 665c255d 2023-08-04 jrmu (define (internal-loop try-again)
615 665c255d 2023-08-04 jrmu (prompt-for-input input-prompt)
616 665c255d 2023-08-04 jrmu (let ((input (read)))
617 665c255d 2023-08-04 jrmu (if (eq? input 'try-again)
618 665c255d 2023-08-04 jrmu (try-again)
621 665c255d 2023-08-04 jrmu (display ";;; Starting a new problem ")
622 665c255d 2023-08-04 jrmu (ambeval input
623 665c255d 2023-08-04 jrmu the-global-environment
624 665c255d 2023-08-04 jrmu ;; ambeval success
625 665c255d 2023-08-04 jrmu (lambda (val next-alternative)
626 665c255d 2023-08-04 jrmu (announce-output output-prompt)
627 665c255d 2023-08-04 jrmu (user-print val)
628 665c255d 2023-08-04 jrmu (internal-loop next-alternative))
629 665c255d 2023-08-04 jrmu ;; ambeval failure
631 665c255d 2023-08-04 jrmu (announce-output
632 665c255d 2023-08-04 jrmu ";;; There are no more values of")
633 665c255d 2023-08-04 jrmu (user-print input)
634 665c255d 2023-08-04 jrmu (driver-loop)))))))
635 665c255d 2023-08-04 jrmu (internal-loop
638 665c255d 2023-08-04 jrmu (display ";;; There is no current problem")
639 665c255d 2023-08-04 jrmu (driver-loop))))
642 665c255d 2023-08-04 jrmu ;; auxiliary
643 665c255d 2023-08-04 jrmu (define (test-case actual expected)
645 665c255d 2023-08-04 jrmu (display "Actual: ")
646 665c255d 2023-08-04 jrmu (display actual)
648 665c255d 2023-08-04 jrmu (display "Expected: ")
649 665c255d 2023-08-04 jrmu (display expected)
651 665c255d 2023-08-04 jrmu (define try-again
653 665c255d 2023-08-04 jrmu "No current problem"))
654 665c255d 2023-08-04 jrmu (define (geval exp) ;; eval globally
655 665c255d 2023-08-04 jrmu (if (eq? exp 'try-again)
656 665c255d 2023-08-04 jrmu (try-again)
657 665c255d 2023-08-04 jrmu (ambeval exp
658 665c255d 2023-08-04 jrmu the-global-environment
659 665c255d 2023-08-04 jrmu (lambda (val next-alternative)
660 665c255d 2023-08-04 jrmu (set! try-again next-alternative)
663 665c255d 2023-08-04 jrmu (set! try-again
665 665c255d 2023-08-04 jrmu "No current problem"))
666 665c255d 2023-08-04 jrmu "No alternatives"))))
667 665c255d 2023-08-04 jrmu (define (test-eval exp expected)
668 665c255d 2023-08-04 jrmu (test-case (geval exp) expected))
669 665c255d 2023-08-04 jrmu (define (print-eval exp)
670 665c255d 2023-08-04 jrmu (user-print (geval exp)))
672 665c255d 2023-08-04 jrmu ;; test-suite
674 665c255d 2023-08-04 jrmu ;; procedure definitions
677 665c255d 2023-08-04 jrmu '(define (append x y)
678 665c255d 2023-08-04 jrmu (if (null? x)
680 665c255d 2023-08-04 jrmu (cons (car x) (append (cdr x) y)))))
682 665c255d 2023-08-04 jrmu '(define (list-ref items n)
683 665c255d 2023-08-04 jrmu (if (= n 0)
684 665c255d 2023-08-04 jrmu (car items)
685 665c255d 2023-08-04 jrmu (list-ref (cdr items) (- n 1)))))
687 665c255d 2023-08-04 jrmu '(define (fold-left f init seq)
688 665c255d 2023-08-04 jrmu (if (null? seq)
690 665c255d 2023-08-04 jrmu (fold-left f
691 665c255d 2023-08-04 jrmu (f init (car seq))
692 665c255d 2023-08-04 jrmu (cdr seq)))))
694 665c255d 2023-08-04 jrmu '(define (enumerate-interval low high)
695 665c255d 2023-08-04 jrmu (if (> low high)
697 665c255d 2023-08-04 jrmu (cons low (enumerate-interval (+ low 1) high)))))
699 665c255d 2023-08-04 jrmu '(define (assoc key records)
700 665c255d 2023-08-04 jrmu (cond ((null? records) false)
701 665c255d 2023-08-04 jrmu ((equal? key (caar records)) (car records))
702 665c255d 2023-08-04 jrmu (else (assoc key (cdr records))))))
705 665c255d 2023-08-04 jrmu '(define (map proc list)
706 665c255d 2023-08-04 jrmu (if (null? list)
708 665c255d 2023-08-04 jrmu (cons (proc (car list))
709 665c255d 2023-08-04 jrmu (map proc (cdr list))))))
711 665c255d 2023-08-04 jrmu '(define (map-2 proc l1 l2)
712 665c255d 2023-08-04 jrmu (if (null? l1)
714 665c255d 2023-08-04 jrmu (cons (proc (car l1) (car l2))
715 665c255d 2023-08-04 jrmu (map-2 proc (cdr l1) (cdr l2))))))
718 665c255d 2023-08-04 jrmu '(define (accumulate op initial sequence)
719 665c255d 2023-08-04 jrmu (if (null? sequence)
721 665c255d 2023-08-04 jrmu (op (car sequence)
722 665c255d 2023-08-04 jrmu (accumulate op initial (cdr sequence))))))
724 665c255d 2023-08-04 jrmu ;; ;; ;; all special forms
725 665c255d 2023-08-04 jrmu ;; (test-eval '(begin 5 6) 6)
726 665c255d 2023-08-04 jrmu ;; (test-eval '10 10)
727 665c255d 2023-08-04 jrmu ;; (geval '(define x 3))
728 665c255d 2023-08-04 jrmu ;; (test-eval 'x 3)
729 665c255d 2023-08-04 jrmu ;; (test-eval '(set! x -25) 'ok)
730 665c255d 2023-08-04 jrmu ;; (test-eval 'x -25)
731 665c255d 2023-08-04 jrmu ;; (geval '(define z (lambda (x y) (+ x (* x y)))))
732 665c255d 2023-08-04 jrmu ;; (test-eval '(z 3 4) 15)
733 665c255d 2023-08-04 jrmu ;; (test-eval '(cond ((= x -2) 'x=-2)
734 665c255d 2023-08-04 jrmu ;; ((= x -25) 'x=-25)
735 665c255d 2023-08-04 jrmu ;; (else 'failed))
737 665c255d 2023-08-04 jrmu ;; (test-eval '(if true false true) false)
739 665c255d 2023-08-04 jrmu ;; (test-eval
740 665c255d 2023-08-04 jrmu ;; '(let ((x 4) (y 7))
741 665c255d 2023-08-04 jrmu ;; (+ x y (* x y)))
742 665c255d 2023-08-04 jrmu ;; (+ 4 7 (* 4 7)))
745 665c255d 2023-08-04 jrmu ;; ;; and/or
746 665c255d 2023-08-04 jrmu ;; (geval '(define x (+ 3 8)))
747 665c255d 2023-08-04 jrmu ;; (test-eval '(and 0 true x) 11)
748 665c255d 2023-08-04 jrmu ;; (test-eval '(and 0 true x false) false)
749 665c255d 2023-08-04 jrmu ;; (test-eval '(and 0 true x (set! x -2) false) false)
750 665c255d 2023-08-04 jrmu ;; (test-eval 'x -2)
751 665c255d 2023-08-04 jrmu ;; (test-eval '(and 0 true x false (set! x -5)) false)
752 665c255d 2023-08-04 jrmu ;; (test-eval 'x -2)
753 665c255d 2023-08-04 jrmu ;; (test-eval '(or false (set! x 25)) 'ok)
754 665c255d 2023-08-04 jrmu ;; (test-eval 'x 25)
755 665c255d 2023-08-04 jrmu ;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
756 665c255d 2023-08-04 jrmu ;; (test-eval 'x 2)
757 665c255d 2023-08-04 jrmu ;; (test-eval '(or false (set! x 25) true false) 'ok)
758 665c255d 2023-08-04 jrmu ;; (test-eval 'x 25)
759 665c255d 2023-08-04 jrmu ;; (test-eval '(or ((lambda (x) x) 5)) 5)
760 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
761 665c255d 2023-08-04 jrmu ;; (newline)
762 665c255d 2023-08-04 jrmu ;; (display "Failure expected")
763 665c255d 2023-08-04 jrmu ;; (newline)
767 665c255d 2023-08-04 jrmu ;; (test-eval
768 665c255d 2023-08-04 jrmu ;; '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
769 665c255d 2023-08-04 jrmu ;; (else false))
772 665c255d 2023-08-04 jrmu ;; (test-eval
773 665c255d 2023-08-04 jrmu ;; '(cond ((= 3 4) 'not-true)
774 665c255d 2023-08-04 jrmu ;; ((= (* 2 4) 3) 'also-false)
775 665c255d 2023-08-04 jrmu ;; ((map (lambda (x)
776 665c255d 2023-08-04 jrmu ;; (* x (+ x 1)))
777 665c255d 2023-08-04 jrmu ;; '(2 4 1 9))
779 665c255d 2023-08-04 jrmu ;; (lambda (x)
780 665c255d 2023-08-04 jrmu ;; (accumulate + 0 x)))
781 665c255d 2023-08-04 jrmu ;; (else 'never-reach))
783 665c255d 2023-08-04 jrmu ;; ;; '(6 20 2 90)
786 665c255d 2023-08-04 jrmu ;; ;; procedure definition and application
788 665c255d 2023-08-04 jrmu ;; '(define (factorial n)
789 665c255d 2023-08-04 jrmu ;; (if (= n 0)
791 665c255d 2023-08-04 jrmu ;; (* n (factorial (- n 1))))))
792 665c255d 2023-08-04 jrmu ;; (test-eval '(factorial 5) 120)
796 665c255d 2023-08-04 jrmu ;; (test-eval
797 665c255d 2023-08-04 jrmu ;; '(map (lambda (x)
798 665c255d 2023-08-04 jrmu ;; (* x (+ x 1)))
799 665c255d 2023-08-04 jrmu ;; '(2 1 4 2 8 3))
800 665c255d 2023-08-04 jrmu ;; '(6 2 20 6 72 12))
801 665c255d 2023-08-04 jrmu ;; ;; accumulate
803 665c255d 2023-08-04 jrmu ;; (test-eval
804 665c255d 2023-08-04 jrmu ;; '(accumulate + 0 '(1 2 3 4 5))
807 665c255d 2023-08-04 jrmu ;; ;; make-let
808 665c255d 2023-08-04 jrmu ;; (test-eval
809 665c255d 2023-08-04 jrmu ;; (make-let '(x y) '(3 5) '((+ x y)))
811 665c255d 2023-08-04 jrmu ;; (test-eval
812 665c255d 2023-08-04 jrmu ;; '(let ()
815 665c255d 2023-08-04 jrmu ;; (test-eval
816 665c255d 2023-08-04 jrmu ;; '(let ((x 3))
819 665c255d 2023-08-04 jrmu ;; (test-eval
820 665c255d 2023-08-04 jrmu ;; '(let ((x 3)
822 665c255d 2023-08-04 jrmu ;; (+ x y))
824 665c255d 2023-08-04 jrmu ;; (test-eval
825 665c255d 2023-08-04 jrmu ;; '(let ((x 3)
827 665c255d 2023-08-04 jrmu ;; (+ (let ((x (+ y 2))
829 665c255d 2023-08-04 jrmu ;; (* x y))
831 665c255d 2023-08-04 jrmu ;; (+ (* 4 3) 3 2))
832 665c255d 2023-08-04 jrmu ;; (test-eval
833 665c255d 2023-08-04 jrmu ;; '(let ((x 6)
834 665c255d 2023-08-04 jrmu ;; (y (let ((x 2))
835 665c255d 2023-08-04 jrmu ;; (+ x 3)))
836 665c255d 2023-08-04 jrmu ;; (z (let ((a (* 3 2)))
837 665c255d 2023-08-04 jrmu ;; (+ a 3))))
838 665c255d 2023-08-04 jrmu ;; (+ x y z))
839 665c255d 2023-08-04 jrmu ;; (+ 6 5 9))
844 665c255d 2023-08-04 jrmu ;; (test-eval
845 665c255d 2023-08-04 jrmu ;; '(let* ((x 3)
846 665c255d 2023-08-04 jrmu ;; (y (+ x 2))
847 665c255d 2023-08-04 jrmu ;; (z (+ x y 5)))
848 665c255d 2023-08-04 jrmu ;; (* x z))
851 665c255d 2023-08-04 jrmu ;; (test-eval
852 665c255d 2023-08-04 jrmu ;; '(let* ()
855 665c255d 2023-08-04 jrmu ;; (test-eval
856 665c255d 2023-08-04 jrmu ;; '(let* ((x 3))
857 665c255d 2023-08-04 jrmu ;; (let* ((y 5))
858 665c255d 2023-08-04 jrmu ;; (+ x y)))
861 665c255d 2023-08-04 jrmu ;; (test-eval
862 665c255d 2023-08-04 jrmu ;; '(let* ((x 3)
863 665c255d 2023-08-04 jrmu ;; (y (+ x 1)))
864 665c255d 2023-08-04 jrmu ;; (+ (let* ((x (+ y 2))
866 665c255d 2023-08-04 jrmu ;; (* x y))
868 665c255d 2023-08-04 jrmu ;; (+ (* 6 6) 3 4))
869 665c255d 2023-08-04 jrmu ;; (test-eval
870 665c255d 2023-08-04 jrmu ;; '(let* ((x 6)
871 665c255d 2023-08-04 jrmu ;; (y (let* ((x 2)
872 665c255d 2023-08-04 jrmu ;; (a (let* ((x (* 3 x)))
873 665c255d 2023-08-04 jrmu ;; (+ x 2))))
874 665c255d 2023-08-04 jrmu ;; (+ x a)))
875 665c255d 2023-08-04 jrmu ;; (z (+ x y)))
876 665c255d 2023-08-04 jrmu ;; (+ x y z))
879 665c255d 2023-08-04 jrmu ;; ;; named-let
881 665c255d 2023-08-04 jrmu ;; (test-eval
882 665c255d 2023-08-04 jrmu ;; '(let eight ()
887 665c255d 2023-08-04 jrmu ;; (test-eval
888 665c255d 2023-08-04 jrmu ;; '(let loop ((count 0))
889 665c255d 2023-08-04 jrmu ;; (if (= 100 count)
891 665c255d 2023-08-04 jrmu ;; (loop (+ count 1))))
894 665c255d 2023-08-04 jrmu ;; '(define (prime? x)
895 665c255d 2023-08-04 jrmu ;; (let prime-iter ((i 2))
896 665c255d 2023-08-04 jrmu ;; (cond ((> (* i i) x) true)
897 665c255d 2023-08-04 jrmu ;; ((= (remainder x i) 0) false)
898 665c255d 2023-08-04 jrmu ;; (else (prime-iter (+ i 1)))))))
899 665c255d 2023-08-04 jrmu ;; (test-eval
900 665c255d 2023-08-04 jrmu ;; '(let primes ((x 2)
902 665c255d 2023-08-04 jrmu ;; (cond ((= n 0) '())
903 665c255d 2023-08-04 jrmu ;; ((prime? x)
905 665c255d 2023-08-04 jrmu ;; (primes (+ x 1) (- n 1))))
906 665c255d 2023-08-04 jrmu ;; (else (primes (+ x 1) n))))
907 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))
910 665c255d 2023-08-04 jrmu ;; '(define (fib n)
911 665c255d 2023-08-04 jrmu ;; (let fib-iter ((a 1)
913 665c255d 2023-08-04 jrmu ;; (count n))
914 665c255d 2023-08-04 jrmu ;; (if (= count 0)
916 665c255d 2023-08-04 jrmu ;; (fib-iter (+ a b) a (- count 1))))))
917 665c255d 2023-08-04 jrmu ;; (test-eval '(fib 19) 4181)
919 665c255d 2023-08-04 jrmu ;; ;; do-loop
920 665c255d 2023-08-04 jrmu ;; (test-eval
921 665c255d 2023-08-04 jrmu ;; '(let ((y 0))
922 665c255d 2023-08-04 jrmu ;; (do ((x 0 (+ x 1)))
923 665c255d 2023-08-04 jrmu ;; ((= x 5) y)
924 665c255d 2023-08-04 jrmu ;; (set! y (+ y 1))))
926 665c255d 2023-08-04 jrmu ;; (test-eval
930 665c255d 2023-08-04 jrmu ;; (test-eval
932 665c255d 2023-08-04 jrmu ;; (true 5))
934 665c255d 2023-08-04 jrmu ;; (test-eval
935 665c255d 2023-08-04 jrmu ;; '(let ((y 0))
937 665c255d 2023-08-04 jrmu ;; ((= y 5) y)
938 665c255d 2023-08-04 jrmu ;; (set! y (+ y 1))))
941 665c255d 2023-08-04 jrmu ;; (test-eval
942 665c255d 2023-08-04 jrmu ;; '(do ((y '(1 2 3 4)))
943 665c255d 2023-08-04 jrmu ;; ((null? y))
944 665c255d 2023-08-04 jrmu ;; (set! y (cdr y)))
946 665c255d 2023-08-04 jrmu ;; (test-eval
947 665c255d 2023-08-04 jrmu ;; '(let ((y 0))
948 665c255d 2023-08-04 jrmu ;; (do ((x 0 (+ x 1)))
949 665c255d 2023-08-04 jrmu ;; ((= x 5) y)
950 665c255d 2023-08-04 jrmu ;; (set! y (+ y 1))))
952 665c255d 2023-08-04 jrmu ;; (test-eval
953 665c255d 2023-08-04 jrmu ;; '(let ((x '(1 3 5 7 9)))
954 665c255d 2023-08-04 jrmu ;; (do ((x x (cdr x))
955 665c255d 2023-08-04 jrmu ;; (sum 0 (+ sum (car x))))
956 665c255d 2023-08-04 jrmu ;; ((null? x) sum)))
958 665c255d 2023-08-04 jrmu ;; (test-eval
959 665c255d 2023-08-04 jrmu ;; '(let ((z '()))
960 665c255d 2023-08-04 jrmu ;; (do ((x '(1 2 3 4) (cdr x))
961 665c255d 2023-08-04 jrmu ;; (y '(1 2 3 4 5 6 7 8) (cddr y)))
962 665c255d 2023-08-04 jrmu ;; ((null? x) y x z)
963 665c255d 2023-08-04 jrmu ;; (set! z (cons (car x) z))))
964 665c255d 2023-08-04 jrmu ;; '(4 3 2 1))
968 665c255d 2023-08-04 jrmu ;; ;; make-unbound!
969 665c255d 2023-08-04 jrmu ;; ;; broken now due to scan-out-defines
971 665c255d 2023-08-04 jrmu ;; ;; (test-eval
972 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 3))
973 665c255d 2023-08-04 jrmu ;; ;; (let ((x 5))
974 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
975 665c255d 2023-08-04 jrmu ;; ;; (* x x)))
978 665c255d 2023-08-04 jrmu ;; ;; (test-eval
979 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 3))
980 665c255d 2023-08-04 jrmu ;; ;; (let ((x 5))
981 665c255d 2023-08-04 jrmu ;; ;; (define y x)
982 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
983 665c255d 2023-08-04 jrmu ;; ;; (* y x)))
986 665c255d 2023-08-04 jrmu ;; ;; (test-eval
987 665c255d 2023-08-04 jrmu ;; ;; '(let ((y -1) (x 3))
988 665c255d 2023-08-04 jrmu ;; ;; (let ((y 0.5) (x 5))
989 665c255d 2023-08-04 jrmu ;; ;; (define a x)
990 665c255d 2023-08-04 jrmu ;; ;; (define b y)
991 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
992 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! y)
993 665c255d 2023-08-04 jrmu ;; ;; (* a b x y)))
994 665c255d 2023-08-04 jrmu ;; ;; (* 5 3 -1 0.5))
996 665c255d 2023-08-04 jrmu ;; ;; (test-eval
997 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 3) (y 4))
998 665c255d 2023-08-04 jrmu ;; ;; (let ((x 5))
999 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
1000 665c255d 2023-08-04 jrmu ;; ;; (+ x 4)))
1003 665c255d 2023-08-04 jrmu ;; ;; (test-eval
1004 665c255d 2023-08-04 jrmu ;; ;; '(let ((a 1) (b 2) (c 3) (d 4))
1005 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! b)
1006 665c255d 2023-08-04 jrmu ;; ;; (+ a c d))
1007 665c255d 2023-08-04 jrmu ;; ;; (+ 1 3 4))
1009 665c255d 2023-08-04 jrmu ;; ;; (test-eval
1010 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 4) (y 5))
1011 665c255d 2023-08-04 jrmu ;; ;; (let ((a 1) (b 2) (c 3))
1012 665c255d 2023-08-04 jrmu ;; ;; (let ((x (+ a b)) (y (+ c a)))
1013 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! x)
1014 665c255d 2023-08-04 jrmu ;; ;; (let ((a x) (b (+ x y)))
1015 665c255d 2023-08-04 jrmu ;; ;; (define z b)
1016 665c255d 2023-08-04 jrmu ;; ;; (make-unbound! b)
1017 665c255d 2023-08-04 jrmu ;; ;; (* (+ a z)
1018 665c255d 2023-08-04 jrmu ;; ;; (+ a b y))))))
1019 665c255d 2023-08-04 jrmu ;; ;; (* (+ 4 8)
1020 665c255d 2023-08-04 jrmu ;; ;; (+ 4 2 4)))
1022 665c255d 2023-08-04 jrmu ;; ;; x 3 -- y 4
1023 665c255d 2023-08-04 jrmu ;; ;; x 4 -- y 4
1024 665c255d 2023-08-04 jrmu ;; ;; a 4 -- b 4
1025 665c255d 2023-08-04 jrmu ;; ;; a 4 -- b 2
1027 665c255d 2023-08-04 jrmu ;; ;; scan-out-defines
1030 665c255d 2023-08-04 jrmu ;; '(define (f x)
1031 665c255d 2023-08-04 jrmu ;; (define (even? n)
1032 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1034 665c255d 2023-08-04 jrmu ;; (odd? (- n 1))))
1035 665c255d 2023-08-04 jrmu ;; (define (odd? n)
1036 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1038 665c255d 2023-08-04 jrmu ;; (even? (- n 1))))
1039 665c255d 2023-08-04 jrmu ;; (even? x)))
1040 665c255d 2023-08-04 jrmu ;; (test-eval '(f 5) false)
1041 665c255d 2023-08-04 jrmu ;; (test-eval '(f 10) true)
1043 665c255d 2023-08-04 jrmu ;; ;; (geval
1044 665c255d 2023-08-04 jrmu ;; ;; '(let ((x 5))
1045 665c255d 2023-08-04 jrmu ;; ;; (define y x)
1046 665c255d 2023-08-04 jrmu ;; ;; (define x 3)
1047 665c255d 2023-08-04 jrmu ;; ;; (+ x y)))
1048 665c255d 2023-08-04 jrmu ;; ;; signal an error because x is undefined if variables are scanned out
1050 665c255d 2023-08-04 jrmu ;; ;; letrec
1053 665c255d 2023-08-04 jrmu ;; '(define (f x)
1054 665c255d 2023-08-04 jrmu ;; (letrec ((even?
1055 665c255d 2023-08-04 jrmu ;; (lambda (n)
1056 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1058 665c255d 2023-08-04 jrmu ;; (odd? (- n 1)))))
1060 665c255d 2023-08-04 jrmu ;; (lambda (n)
1061 665c255d 2023-08-04 jrmu ;; (if (= n 0)
1063 665c255d 2023-08-04 jrmu ;; (even? (- n 1))))))
1064 665c255d 2023-08-04 jrmu ;; (even? x))))
1065 665c255d 2023-08-04 jrmu ;; (test-eval '(f 11) false)
1066 665c255d 2023-08-04 jrmu ;; (test-eval '(f 16) true)
1068 665c255d 2023-08-04 jrmu ;; (test-eval
1069 665c255d 2023-08-04 jrmu ;; '(letrec ((fact
1070 665c255d 2023-08-04 jrmu ;; (lambda (n)
1071 665c255d 2023-08-04 jrmu ;; (if (= n 1)
1073 665c255d 2023-08-04 jrmu ;; (* n (fact (- n 1)))))))
1074 665c255d 2023-08-04 jrmu ;; (fact 10))
1075 665c255d 2023-08-04 jrmu ;; 3628800)
1078 665c255d 2023-08-04 jrmu (geval '(define (require p) (if (not p) (amb))))
1080 665c255d 2023-08-04 jrmu ;; (test-eval '(amb 1 2 3) 1)
1081 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 2)
1082 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 3)
1083 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again "No alternatives")
1084 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again "No current problem")
1085 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again "No current problem")
1086 665c255d 2023-08-04 jrmu ;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
1088 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 2)
1089 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 'a)
1090 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again 'b)
1091 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again "No alternatives")
1092 665c255d 2023-08-04 jrmu ;; (test-eval '(require false) "No alternatives")
1093 665c255d 2023-08-04 jrmu ;; (test-eval '(require true) false)
1097 665c255d 2023-08-04 jrmu '(define (an-integer-between low high)
1098 665c255d 2023-08-04 jrmu (require (<= low high))
1099 665c255d 2023-08-04 jrmu (amb low (an-integer-between (+ low 1) high))))
1102 665c255d 2023-08-04 jrmu '(define (a-pythagorean-triple-between low high)
1103 665c255d 2023-08-04 jrmu (let ((i (an-integer-between low high)))
1104 665c255d 2023-08-04 jrmu (let ((j (an-integer-between i high)))
1105 665c255d 2023-08-04 jrmu (let ((k (an-integer-between j high)))
1106 665c255d 2023-08-04 jrmu (require (= (+ (* i i) (* j j)) (* k k)))
1107 665c255d 2023-08-04 jrmu (list i j k))))))
1109 665c255d 2023-08-04 jrmu ;; (test-eval
1110 665c255d 2023-08-04 jrmu ;; '(a-pythagorean-triple-between 1 20)
1111 665c255d 2023-08-04 jrmu ;; '(3 4 5))
1112 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(5 12 13))
1113 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(6 8 10))
1114 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(8 15 17))
1115 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(9 12 15))
1118 665c255d 2023-08-04 jrmu '(define (an-integer-starting-from low)
1119 665c255d 2023-08-04 jrmu (amb low (an-integer-starting-from (+ low 1)))))
1122 665c255d 2023-08-04 jrmu '(define (pythagorean-triples-starting-from low)
1123 665c255d 2023-08-04 jrmu (let* ((k (an-integer-starting-from low))
1124 665c255d 2023-08-04 jrmu (i (an-integer-between low k))
1125 665c255d 2023-08-04 jrmu (j (an-integer-between i k)))
1126 665c255d 2023-08-04 jrmu (require (= (+ (* i i) (* j j)) (* k k)))
1127 665c255d 2023-08-04 jrmu (list i j k))))
1129 665c255d 2023-08-04 jrmu ;; (test-eval '(pythagorean-triples-starting-from 1)
1130 665c255d 2023-08-04 jrmu ;; '(3 4 5))
1131 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(6 8 10))
1132 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(5 12 13))
1133 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(9 12 15))
1134 665c255d 2023-08-04 jrmu ;; (test-eval 'try-again '(8 15 17))
1137 665c255d 2023-08-04 jrmu '(define (next-triplet trp)
1138 665c255d 2023-08-04 jrmu (let ((i (car trp))
1139 665c255d 2023-08-04 jrmu (j (cadr trp))
1140 665c255d 2023-08-04 jrmu (k (caddr trp)))
1141 665c255d 2023-08-04 jrmu (cond ((= i j k) (list 1 1 (+ k 1)))
1142 665c255d 2023-08-04 jrmu ((= j k) (list (+ i 1) (+ i 1) k))
1143 665c255d 2023-08-04 jrmu (else (list i (+ j 1) k))))))
1145 665c255d 2023-08-04 jrmu '(define (triplet-starting-from trp)
1146 665c255d 2023-08-04 jrmu (amb trp (triplet-starting-from (next-triplet trp)))))
1148 665c255d 2023-08-04 jrmu '(define (pythagorean-triples-starting-from low)
1149 665c255d 2023-08-04 jrmu (let* ((triplet (triplet-starting-from (list low low low)))
1150 665c255d 2023-08-04 jrmu (i (car triplet))
1151 665c255d 2023-08-04 jrmu (j (cadr triplet))
1152 665c255d 2023-08-04 jrmu (k (caddr triplet)))
1153 665c255d 2023-08-04 jrmu (require (= (+ (* i i) (* j j)) (* k k)))
1154 665c255d 2023-08-04 jrmu (list i j k))))
1156 665c255d 2023-08-04 jrmu '(define (distinct? items)
1157 665c255d 2023-08-04 jrmu (cond ((null? items) true)
1158 665c255d 2023-08-04 jrmu ((null? (cdr items)) true)
1159 665c255d 2023-08-04 jrmu ((member (car items) (cdr items)) false)
1160 665c255d 2023-08-04 jrmu (else (distinct? (cdr items))))))
1163 665c255d 2023-08-04 jrmu '(define nouns '(noun student professor cat class)))
1165 665c255d 2023-08-04 jrmu '(define verbs '(verb studies lectures eats sleeps)))
1167 665c255d 2023-08-04 jrmu '(define articles '(article the a)))
1169 665c255d 2023-08-04 jrmu '(define prepositions '(prep for to in by with)))
1172 665c255d 2023-08-04 jrmu '(define (parse-sentence)
1173 665c255d 2023-08-04 jrmu (list 'sentence
1174 665c255d 2023-08-04 jrmu (parse-noun-phrase)
1175 665c255d 2023-08-04 jrmu (parse-verb-phrase))))
1177 665c255d 2023-08-04 jrmu '(define (parse-verb-phrase)
1178 665c255d 2023-08-04 jrmu (define (maybe-extend verb-phrase)
1179 665c255d 2023-08-04 jrmu (amb verb-phrase
1180 665c255d 2023-08-04 jrmu (maybe-extend
1181 665c255d 2023-08-04 jrmu (list 'verb-phrase
1182 665c255d 2023-08-04 jrmu verb-phrase
1183 665c255d 2023-08-04 jrmu (parse-prepositional-phrase)))))
1184 665c255d 2023-08-04 jrmu (maybe-extend (parse-word verbs))))
1186 665c255d 2023-08-04 jrmu '(define (parse-simple-noun-phrase)
1187 665c255d 2023-08-04 jrmu (list 'simple-noun-phrase
1188 665c255d 2023-08-04 jrmu (parse-word articles)
1189 665c255d 2023-08-04 jrmu (parse-word nouns))))
1191 665c255d 2023-08-04 jrmu '(define (parse-noun-phrase)
1192 665c255d 2023-08-04 jrmu (define (maybe-extend noun-phrase)
1193 665c255d 2023-08-04 jrmu (amb noun-phrase
1194 665c255d 2023-08-04 jrmu (maybe-extend
1195 665c255d 2023-08-04 jrmu (list 'noun-phrase
1196 665c255d 2023-08-04 jrmu noun-phrase
1197 665c255d 2023-08-04 jrmu (parse-prepositional-phrase)))))
1198 665c255d 2023-08-04 jrmu (maybe-extend (parse-simple-noun-phrase))))
1200 665c255d 2023-08-04 jrmu '(define (parse-prepositional-phrase)
1201 665c255d 2023-08-04 jrmu (list 'prep-phrase
1202 665c255d 2023-08-04 jrmu (parse-word prepositions)
1203 665c255d 2023-08-04 jrmu (parse-noun-phrase))))
1205 665c255d 2023-08-04 jrmu '(define (parse-word word-list)
1206 665c255d 2023-08-04 jrmu (require (not (null? *unparsed*)))
1207 665c255d 2023-08-04 jrmu (require (memq (car *unparsed*) (cdr word-list)))
1208 665c255d 2023-08-04 jrmu (let ((found-word (car *unparsed*)))
1209 665c255d 2023-08-04 jrmu (set! *unparsed* (cdr *unparsed*))
1210 665c255d 2023-08-04 jrmu (list (car word-list) found-word))))
1212 665c255d 2023-08-04 jrmu '(define *unparsed* '()))
1214 665c255d 2023-08-04 jrmu '(define (parse input)
1215 665c255d 2023-08-04 jrmu (set! *unparsed* input)
1216 665c255d 2023-08-04 jrmu (let ((sent (parse-sentence)))
1217 665c255d 2023-08-04 jrmu (require (null? *unparsed*))
1220 665c255d 2023-08-04 jrmu ;; (print-eval '(parse '(the cat eats)))
1221 665c255d 2023-08-04 jrmu ;; (newline)
1222 665c255d 2023-08-04 jrmu ;; (print-eval '(parse '(the student with the cat sleeps in the class)))
1223 665c255d 2023-08-04 jrmu ;; (newline)
1224 665c255d 2023-08-04 jrmu ;; (print-eval '(parse '(the professor lectures to the student with the cat)))
1225 665c255d 2023-08-04 jrmu ;; (newline)
1226 665c255d 2023-08-04 jrmu ;; (print-eval 'try-again)
1228 665c255d 2023-08-04 jrmu Exercise 4.48. Extend the grammar given above to handle more complex sentences. For example, you could extend noun phrases and verb phrases to include adjectives and adverbs, or you could handle compound sentences.53
