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