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