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