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-default exp)))
68 	(aproc (analyze (if-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-default exp)
288   (cadr exp))
289 (define (if-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 'eq? eq?)
608 	(list 'equal? equal?)
609 	(list 'member member)
610 	(list 'memq memq)
611 	(list 'display display)
612 	(list 'error error)))
613 (define (primitive-procedure-names)
614   (map car
615        primitive-procedures))
616 (define (primitive-procedure-objects)
617   (map (lambda (proc) (list 'primitive (cadr proc)))
618        primitive-procedures))
619 (define (apply-primitive-procedure proc args)
620   (apply
621    (primitive-implementation proc) args))
622 
623 ;; execute application
624 
625 (define (execute-application proc args succeed fail)
626   (cond ((primitive-procedure? proc)
627          (succeed (apply-primitive-procedure proc args)
628                   fail))
629         ((compound-procedure? proc)
630          ((procedure-body proc)
631           (extend-environment (procedure-parameters proc)
632                               args
633                               (procedure-environment proc))
634           succeed
635           fail))
636         (else
637          (error
638           "Unknown procedure type -- EXECUTE-APPLICATION"
639           proc))))
640 
641 
642 ;; driver-loop
643 (define (prompt-for-input string)
644   (newline) (newline) (display string) (newline))
645 (define (announce-output string)
646   (newline) (display string) (newline))
647 (define (user-print object)
648   (if (compound-procedure? object)
649       (display (list 'compound-procedure
650                      (procedure-parameters object)
651                      (procedure-body object)
652                      '<procedure-env>))
653       (display object)))
654 (define (setup-environment)
655   (let ((initial-env
656          (extend-environment (primitive-procedure-names)
657                              (primitive-procedure-objects)
658                              the-empty-environment)))
659     (define-variable! 'true true initial-env)
660     (define-variable! 'false false initial-env)
661     initial-env))
662 (define the-global-environment (setup-environment))
663 
664 (define input-prompt ";;; Amb-Eval input:")
665 (define output-prompt ";;; Amb-Eval value:")
666 (define (driver-loop)
667   (define (internal-loop try-again)
668     (prompt-for-input input-prompt)
669     (let ((input (read)))
670       (if (eq? input 'try-again)
671           (try-again)
672           (begin
673             (newline)
674             (display ";;; Starting a new problem ")
675             (ambeval input
676                      the-global-environment
677                      ;; ambeval success
678                      (lambda (val next-alternative)
679                        (announce-output output-prompt)
680                        (user-print val)
681                        (internal-loop next-alternative))
682                      ;; ambeval failure
683                      (lambda ()
684                        (announce-output
685                         ";;; There are no more values of")
686                        (user-print input)
687                        (driver-loop)))))))
688   (internal-loop
689    (lambda ()
690      (newline)
691      (display ";;; There is no current problem")
692      (driver-loop))))
693 
694 
695 ;; auxiliary
696 (define (test-case actual expected)
697   (newline)
698   (display "Actual:   ")
699   (display actual)
700   (newline)
701   (display "Expected: ")
702   (display expected)
703   (newline))
704 (define try-again
705   (lambda ()
706     "No current problem"))
707 (define (geval exp) ;; eval globally
708   (if (eq? exp 'try-again)
709       (try-again)
710       (ambeval exp 
711 	       the-global-environment
712 	       (lambda (val next-alternative)
713 		 (set! try-again next-alternative)
714 		 val)
715 	       (lambda ()
716 		 (set! try-again
717 		       (lambda ()
718 			 "No current problem"))
719 		 "No alternatives"))))
720 (define (test-eval exp expected)
721   (test-case (geval exp) expected))
722 (define (print-eval exp)
723   (user-print (geval exp)))
724 
725 ;; test-suite
726 
727 ;; procedure definitions
728 
729 (geval
730  '(define (append x y)
731     (if (null? x)
732 	y
733 	(cons (car x) (append (cdr x) y)))))
734 (geval
735  '(define (list-ref items n)
736     (if (= n 0)
737 	(car items)
738 	(list-ref (cdr items) (- n 1)))))
739 (geval
740  '(define (fold-left f init seq) 
741     (if (null? seq) 
742 	init 
743 	(fold-left f 
744 		   (f init (car seq)) 
745 		   (cdr seq)))))
746 (geval
747  '(define (enumerate-interval low high)
748     (if (> low high)
749 	'()
750 	(cons low (enumerate-interval (+ low 1) high)))))
751 (geval 
752  '(define (assoc key records)
753     (cond ((null? records) false)
754 	  ((equal? key (caar records)) (car records))
755 	  (else (assoc key (cdr records))))))
756 
757 (geval
758  '(define (map proc list)
759     (if (null? list)
760 	'()
761 	(cons (proc (car list))
762 	      (map proc (cdr list))))))
763 (geval
764  '(define (map-2 proc l1 l2)
765     (if (null? l1)
766 	'()
767 	(cons (proc (car l1) (car l2))
768 	      (map-2 proc (cdr l1) (cdr l2))))))
769 
770 (geval 
771  '(define (accumulate op initial sequence)
772     (if (null? sequence)
773 	initial
774 	(op (car sequence)
775 	    (accumulate op initial (cdr sequence))))))
776 
777 ;; ;; ;; all special forms
778 ;; (test-eval '(begin 5 6) 6)
779 ;; (test-eval '10 10)
780 ;; (geval '(define x 3))
781 ;; (test-eval 'x 3)
782 ;; (test-eval '(set! x -25) 'ok)
783 ;; (test-eval 'x -25)
784 ;; (geval '(define z (lambda (x y) (+ x (* x y)))))
785 ;; (test-eval '(z 3 4) 15)
786 ;; (test-eval '(cond ((= x -2) 'x=-2)
787 ;; 		  ((= x -25) 'x=-25)
788 ;; 		  (else 'failed))
789 ;; 	   'x=-25)
790 ;; (test-eval '(if true false true) false)
791 
792 ;; (test-eval 
793 ;;  '(let ((x 4) (y 7))
794 ;;     (+ x y (* x y)))
795 ;;  (+ 4 7 (* 4 7)))
796 
797 
798 ;; ;; and/or
799 ;; (geval '(define x (+ 3 8)))
800 ;; (test-eval '(and 0 true x) 11)
801 ;; (test-eval '(and 0 true x false) false)
802 ;; (test-eval '(and 0 true x (set! x -2) false) false)
803 ;; (test-eval 'x -2)
804 ;; (test-eval '(and 0 true x false (set! x -5)) false)
805 ;; (test-eval 'x -2)
806 ;; (test-eval '(or false (set! x 25)) 'ok)
807 ;; (test-eval 'x 25)
808 ;; (test-eval '(or (set! x 2) (set! x 4)) 'ok)
809 ;; (test-eval 'x 2)
810 ;; (test-eval '(or false (set! x 25) true false) 'ok)
811 ;; (test-eval 'x 25)
812 ;; (test-eval '(or ((lambda (x) x) 5)) 5)
813 ;; (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
814 ;; (newline)
815 ;; (display "Failure expected")
816 ;; (newline)
817 
818 ;; ;; cond
819 
820 ;; (test-eval 
821 ;;  '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
822 ;; 	(else false))
823 ;;  2)
824 
825 ;; (test-eval
826 ;;  '(cond ((= 3 4) 'not-true)
827 ;; 	((= (* 2 4) 3) 'also-false)
828 ;; 	((map (lambda (x)
829 ;; 		(* x (+ x 1)))
830 ;; 	      '(2 4 1 9))
831 ;; 	 =>
832 ;; 	 (lambda (x)
833 ;; 	   (accumulate + 0 x)))
834 ;; 	(else 'never-reach))
835 ;;  118)
836 ;; ;; '(6 20 2 90)
837 
838 
839 ;; ;; procedure definition and application
840 ;; (geval
841 ;;  '(define (factorial n)
842 ;;     (if (= n 0)
843 ;; 	1
844 ;; 	(* n (factorial (- n 1))))))
845 ;; (test-eval '(factorial 5) 120)
846 
847 ;; ;; map
848 
849 ;; (test-eval
850 ;;  '(map (lambda (x)
851 ;; 	 (* x (+ x 1)))
852 ;;        '(2 1 4 2 8 3))
853 ;;  '(6 2 20 6 72 12))
854 ;; ;; accumulate
855 
856 ;; (test-eval
857 ;;  '(accumulate + 0 '(1 2 3 4 5))
858 ;;  15)
859 
860 ;; ;; make-let
861 ;; (test-eval 
862 ;;  (make-let '(x y) '(3 5) '((+ x y)))
863 ;;  8)
864 ;; (test-eval 
865 ;;  '(let ()
866 ;;     5)
867 ;;  5)
868 ;; (test-eval
869 ;;  '(let ((x 3))
870 ;;     x)
871 ;;  3)
872 ;; (test-eval
873 ;;  '(let ((x 3)
874 ;; 	(y 5))
875 ;;     (+ x y))
876 ;;  8)
877 ;; (test-eval 
878 ;;  '(let ((x 3)
879 ;; 	(y 2))
880 ;;     (+ (let ((x (+ y 2))
881 ;; 	     (y x))
882 ;; 	 (* x y))
883 ;;        x y))
884 ;;  (+ (* 4 3) 3 2))
885 ;; (test-eval
886 ;;  '(let ((x 6)
887 ;; 	(y (let ((x 2))
888 ;; 	     (+ x 3)))
889 ;; 	(z (let ((a (* 3 2)))
890 ;; 	     (+ a 3))))
891 ;;     (+ x y z))
892 ;;  (+ 6 5 9))
893     
894 
895 ;; ;; let*
896 
897 ;; (test-eval
898 ;;  '(let* ((x 3)
899 ;; 	 (y (+ x 2))
900 ;; 	 (z (+ x y 5)))
901 ;;     (* x z))
902 ;;  39)
903 
904 ;; (test-eval
905 ;;  '(let* ()
906 ;;     5)
907 ;;  5)
908 ;; (test-eval
909 ;;  '(let* ((x 3))
910 ;;     (let* ((y 5))
911 ;;       (+ x y)))
912 ;;  8)
913 
914 ;; (test-eval 
915 ;;  '(let* ((x 3)
916 ;; 	 (y (+ x 1)))
917 ;;     (+ (let* ((x (+ y 2))
918 ;; 	      (y x))
919 ;; 	 (* x y))
920 ;;        x y))
921 ;;  (+ (* 6 6) 3 4))
922 ;; (test-eval
923 ;;  '(let* ((x 6)
924 ;; 	 (y (let* ((x 2)
925 ;; 		   (a (let* ((x (* 3 x)))
926 ;; 			(+ x 2))))       
927 ;; 	      (+ x a)))                  
928 ;; 	 (z (+ x y)))                    
929 ;;     (+ x y z))
930 ;;  32)
931 
932 ;; ;; named-let
933 
934 ;; (test-eval
935 ;;  '(let eight ()
936 ;;     5
937 ;;     7
938 ;;     8)
939 ;;  8)
940 ;; (test-eval
941 ;;  '(let loop ((count 0))
942 ;;     (if (= 100 count)
943 ;; 	count
944 ;; 	(loop (+ count 1))))
945 ;;  100)
946 ;; (geval
947 ;;  '(define (prime? x)
948 ;;     (let prime-iter ((i 2))
949 ;;       (cond ((> (* i i) x) true)
950 ;; 	    ((= (remainder x i) 0) false)
951 ;; 	    (else (prime-iter (+ i 1)))))))
952 ;; (test-eval
953 ;;  '(let primes ((x 2)
954 ;; 	       (n 20))
955 ;;     (cond ((= n 0) '())
956 ;; 	  ((prime? x) 
957 ;; 	   (cons x
958 ;; 		 (primes (+ x 1) (- n 1))))
959 ;; 	  (else (primes (+ x 1) n))))
960 ;;  '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
961 
962 ;; (geval
963 ;;  '(define (fib n)
964 ;;     (let fib-iter ((a 1)
965 ;; 		   (b 0)
966 ;; 		   (count n))
967 ;;       (if (= count 0)
968 ;; 	  b
969 ;; 	  (fib-iter (+ a b) a (- count 1))))))
970 ;; (test-eval '(fib 19) 4181)
971 
972 ;; ;; do-loop	  
973 ;; (test-eval
974 ;;  '(let ((y 0))
975 ;;     (do ((x 0 (+ x 1)))
976 ;; 	((= x 5) y)
977 ;;       (set! y (+ y 1))))
978 ;;  5)
979 ;; (test-eval
980 ;;  '(do ()
981 ;;       (true))
982 ;;  true)
983 ;; (test-eval
984 ;;  '(do ()
985 ;;       (true 5))
986 ;;  5)
987 ;; (test-eval
988 ;;  '(let ((y 0))
989 ;;     (do ()
990 ;; 	((= y 5) y)
991 ;;       (set! y (+ y 1))))
992 ;;  5)
993 
994 ;; (test-eval
995 ;;  '(do ((y '(1 2 3 4)))
996 ;;       ((null? y))
997 ;;     (set! y (cdr y)))
998 ;;  true)
999 ;; (test-eval
1000 ;;  '(let ((y 0))
1001 ;;     (do ((x 0 (+ x 1)))
1002 ;; 	((= x 5) y)
1003 ;;       (set! y (+ y 1))))
1004 ;;  5)
1005 ;; (test-eval
1006 ;;  '(let ((x '(1 3 5 7 9)))
1007 ;;     (do ((x x (cdr x))
1008 ;; 	 (sum 0 (+ sum (car x))))
1009 ;; 	((null? x) sum)))
1010 ;;  25)
1011 ;; (test-eval 
1012 ;;  '(let ((z '()))
1013 ;;     (do ((x '(1 2 3 4) (cdr x))
1014 ;; 	 (y '(1 2 3 4 5 6 7 8) (cddr y)))
1015 ;; 	((null? x) y x z)
1016 ;;       (set! z (cons (car x) z))))
1017 ;;  '(4 3 2 1))
1018 
1019 
1020 
1021 ;; ;; make-unbound!
1022 ;; ;; broken now due to scan-out-defines
1023 
1024 ;; ;; (test-eval
1025 ;; ;;  '(let ((x 3))
1026 ;; ;;     (let ((x 5))
1027 ;; ;;       (make-unbound! x)
1028 ;; ;;       (* x x)))
1029 ;; ;;  9)
1030 
1031 ;; ;; (test-eval
1032 ;; ;;  '(let ((x 3))
1033 ;; ;;     (let ((x 5))
1034 ;; ;;       (define y x)
1035 ;; ;;       (make-unbound! x)
1036 ;; ;;       (* y x)))
1037 ;; ;;  15)
1038 
1039 ;; ;; (test-eval
1040 ;; ;;  '(let ((y -1) (x 3))
1041 ;; ;;     (let ((y 0.5) (x 5))
1042 ;; ;;       (define a x)
1043 ;; ;;       (define b y)
1044 ;; ;;       (make-unbound! x)
1045 ;; ;;       (make-unbound! y)
1046 ;; ;;       (* a b x y)))
1047 ;; ;;  (* 5 3 -1 0.5))
1048 
1049 ;; ;; (test-eval
1050 ;; ;;  '(let ((x 3) (y 4))
1051 ;; ;;     (let ((x 5))
1052 ;; ;;       (make-unbound! x)
1053 ;; ;;       (+ x 4)))
1054 ;; ;;  7)
1055 
1056 ;; ;; (test-eval 
1057 ;; ;;  '(let ((a 1) (b 2) (c 3) (d 4))
1058 ;; ;;     (make-unbound! b)
1059 ;; ;;     (+ a c d))
1060 ;; ;;  (+ 1 3 4))
1061 
1062 ;; ;; (test-eval
1063 ;; ;;  '(let ((x 4) (y 5))
1064 ;; ;;     (let ((a 1) (b 2) (c 3))
1065 ;; ;;       (let ((x (+ a b)) (y (+ c a)))
1066 ;; ;; 	(make-unbound! x)
1067 ;; ;; 	(let ((a x) (b (+ x y)))
1068 ;; ;; 	  (define z b)
1069 ;; ;; 	  (make-unbound! b)
1070 ;; ;; 	  (* (+ a z)
1071 ;; ;; 	     (+ a b y))))))
1072 ;; ;;  (* (+ 4 8)
1073 ;; ;;     (+ 4 2 4)))
1074  
1075 ;; ;; x 3 -- y 4
1076 ;; ;; x 4 -- y 4
1077 ;; ;; a 4 -- b 4
1078 ;; ;; a 4 -- b 2
1079 
1080 ;; ;; scan-out-defines
1081 
1082 ;; (geval
1083 ;;  '(define (f x)
1084 ;;     (define (even? n)
1085 ;;       (if (= n 0)
1086 ;; 	  true
1087 ;; 	  (odd? (- n 1))))
1088 ;;     (define (odd? n)
1089 ;;       (if (= n 0)
1090 ;; 	  false
1091 ;; 	  (even? (- n 1))))
1092 ;;     (even? x)))
1093 ;; (test-eval '(f 5) false)
1094 ;; (test-eval '(f 10) true)
1095 
1096 ;; ;; (geval
1097 ;; ;;  '(let ((x 5))
1098 ;; ;;     (define y x)
1099 ;; ;;     (define x 3)
1100 ;; ;;     (+ x y)))
1101 ;; ;; signal an error because x is undefined if variables are scanned out
1102 
1103 ;; ;; letrec
1104 
1105 ;; (geval
1106 ;;  '(define (f x)
1107 ;;     (letrec ((even?
1108 ;; 	      (lambda (n)
1109 ;; 		(if (= n 0)
1110 ;; 		    true
1111 ;; 		    (odd? (- n 1)))))
1112 ;; 	     (odd?
1113 ;; 	      (lambda (n)
1114 ;; 		(if (= n 0)
1115 ;; 		    false
1116 ;; 		    (even? (- n 1))))))
1117 ;;       (even? x))))
1118 ;; (test-eval '(f 11) false)
1119 ;; (test-eval '(f 16) true)
1120 
1121 ;; (test-eval 
1122 ;;  '(letrec ((fact
1123 ;; 	    (lambda (n)
1124 ;; 	      (if (= n 1)
1125 ;; 		  1
1126 ;; 		  (* n (fact (- n 1)))))))
1127 ;;     (fact 10))
1128 ;;  3628800)
1129 
1130 ;; amb
1131 (geval '(define (require p) (if (not p) (amb))))
1132 
1133 ;; (test-eval '(amb 1 2 3) 1)
1134 ;; (test-eval 'try-again 2)
1135 ;; (test-eval 'try-again 3)
1136 ;; (test-eval 'try-again "No alternatives")
1137 ;; (test-eval 'try-again "No current problem")
1138 ;; (test-eval 'try-again "No current problem")
1139 ;; (test-eval '(amb (amb 1 2) (amb 'a 'b))
1140 ;; 	   1)
1141 ;; (test-eval 'try-again 2)
1142 ;; (test-eval 'try-again 'a)
1143 ;; (test-eval 'try-again 'b)
1144 ;; (test-eval 'try-again "No alternatives")
1145 ;; (test-eval '(require false) "No alternatives")
1146 ;; (test-eval '(require true) false)
1147 
1148 	   
1149 (geval
1150  '(define (an-integer-between low high)
1151     (require (<= low high))
1152     (amb low (an-integer-between (+ low 1) high))))
1153 
1154 (geval 
1155  '(define (a-pythagorean-triple-between low high)
1156     (let ((i (an-integer-between low high)))
1157       (let ((j (an-integer-between i high)))
1158 	(let ((k (an-integer-between j high)))
1159 	  (require (= (+ (* i i) (* j j)) (* k k)))
1160 	  (list i j k))))))
1161 
1162 ;; (test-eval
1163 ;;  '(a-pythagorean-triple-between 1 20)
1164 ;;  '(3 4 5))
1165 ;; (test-eval 'try-again '(5 12 13))
1166 ;; (test-eval 'try-again '(6 8 10))
1167 ;; (test-eval 'try-again '(8 15 17))
1168 ;; (test-eval 'try-again '(9 12 15))
1169 
1170 (geval
1171  '(define (an-integer-starting-from low)
1172     (amb low (an-integer-starting-from (+ low 1)))))
1173 
1174 (geval
1175  '(define (pythagorean-triples-starting-from low)
1176     (let* ((k (an-integer-starting-from low))
1177 	   (i (an-integer-between low k))
1178 	   (j (an-integer-between i k)))
1179       (require (= (+ (* i i) (* j j)) (* k k)))
1180       (list i j k))))
1181 
1182 ;; (test-eval '(pythagorean-triples-starting-from 1)
1183 ;; 	   '(3 4 5))
1184 ;; (test-eval 'try-again '(6 8 10))
1185 ;; (test-eval 'try-again '(5 12 13))
1186 ;; (test-eval 'try-again '(9 12 15))
1187 ;; (test-eval 'try-again '(8 15 17))
1188 
1189 (geval
1190  '(define (next-triplet trp)
1191     (let ((i (car trp))
1192 	  (j (cadr trp))
1193 	  (k (caddr trp)))
1194       (cond ((= i j k) (list 1 1 (+ k 1)))
1195 	    ((= j k) (list (+ i 1) (+ i 1) k))
1196 	    (else (list i (+ j 1) k))))))
1197 (geval
1198  '(define (triplet-starting-from trp)
1199     (amb trp (triplet-starting-from (next-triplet trp)))))
1200 (geval
1201  '(define (pythagorean-triples-starting-from low)
1202     (let* ((triplet (triplet-starting-from (list low low low)))
1203 	   (i (car triplet))
1204 	   (j (cadr triplet))
1205 	   (k (caddr triplet)))
1206       (require (= (+ (* i i) (* j j)) (* k k)))
1207       (list i j k))))
1208 (geval
1209  '(define (distinct? items)
1210     (cond ((null? items) true)
1211 	  ((null? (cdr items)) true)
1212 	  ((member (car items) (cdr items)) false)
1213 	  (else (distinct? (cdr items))))))
1214 
1215 (geval
1216  '(define (an-element-of items)
1217     (require (not (null? items)))
1218     (amb (car items) (an-element-of (cdr items)))))
1219 
1220 (geval 
1221  '(define count 0))
1222 (test-eval
1223  '(let ((x (an-element-of '(a b c)))
1224 	(y (an-element-of '(a b c))))
1225     (permanent-set! count (+ count 1))
1226     (require (not (eq? x y)))
1227     (list x y count))
1228  '(a b 2))
1229 (test-eval 'try-again '(a c 3))
1230 
1231 (test-eval
1232  '(if-fail (let ((x (an-element-of '(1 3 5))))
1233 	     (require (even? x))
1234 	     x)
1235 	   'all-odd)
1236  'all-odd)
1237 (test-eval 'try-again "No alternatives")
1238 
1239 (test-eval
1240  '(if-fail (let ((x (an-element-of '(1 3 5 8))))
1241 	     (require (even? x))
1242 	     x)
1243 	   'all-odd)
1244  8)
1245 (test-eval 'try-again "No alternatives")
1246