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