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