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             (else (scan (cdr vars) (cdr vals)))))
480     (if (eq? env the-empty-environment)
481         (error "Unbound variable" var)
482         (let ((frame (first-frame env)))
483           (scan (frame-variables frame)
484                 (frame-values frame)))))
485   (env-loop env))
486 (define (set-variable-value! var val env)
487   (define (env-loop env)
488     (define (scan vars vals)
489       (cond ((null? vars)
490              (env-loop (enclosing-environment env)))
491             ((eq? var (car vars))
492              (set-car! vals val))
493             (else (scan (cdr vars) (cdr vals)))))
494     (if (eq? env the-empty-environment)
495         (error "Unbound variable -- SET!" var)
496         (let ((frame (first-frame env)))
497           (scan (frame-variables frame)
498                 (frame-values frame)))))
499   (env-loop env))
500 (define (define-variable! var val env)
501   (let ((frame (first-frame env)))
502     (define (scan vars vals)
503       (cond ((null? vars)
504              (add-binding-to-frame! var val frame))
505             ((eq? var (car vars))
506              (set-car! vals val))
507             (else (scan (cdr vars) (cdr vals)))))
508     (scan (frame-variables frame)
509           (frame-values frame))))
510 
511 ;; (define (remove-binding-from-frame! var frame)
512 ;;   (define (scan vars vals)
513 ;;     (cond ((null? (cdr vars))
514 ;; 	   (error "Binding not found -- REMOVE-BINDING-FROM-FRAME!" var))
515 ;; 	  ((eq? var (cadr vars))
516 ;; 	   (set-cdr! vars (cddr vars))
517 ;; 	   (set-cdr! vals (cddr vals)))
518 ;; 	  (else (scan (cdr vars) (cdr vals)))))
519 ;;   (let ((vars (frame-variables frame))
520 ;; 	(vals (frame-values frame)))
521 ;;     (if (eq? var (car vars))
522 ;; 	(begin (set-car! frame (cdr vars))
523 ;; 	       (set-cdr! frame (cdr vals)))
524 ;; 	(scan vars vals))))
525 
526 ;; primitives
527 (define (primitive-procedure? proc)
528   (tagged-list? proc 'primitive))
529 (define (primitive-implementation proc) (cadr proc))
530 (define primitive-procedures
531   (list (list 'car car)
532         (list 'cdr cdr)
533 	(list 'caar caar)
534 	(list 'cadr cadr)
535 	(list 'cddr cddr)
536 	(list 'caddr caddr)
537 	(list 'cdddr cdddr)
538         (list 'cons cons)
539 	(list 'list list)
540         (list 'null? null?)
541 	(list '* *)
542 	(list '/ /)
543 	(list '+ +)
544 	(list '- -)
545 	(list '= =)
546 	(list '< <)
547 	(list '> >)
548 	(list '<= <=)
549 	(list '>= >=)
550 	(list 'abs abs)
551 	(list 'remainder remainder)
552 	(list 'eq? eq?)
553 	(list 'equal? equal?)
554 	(list 'member member)
555 	(list 'display display)))
556 (define (primitive-procedure-names)
557   (map car
558        primitive-procedures))
559 (define (primitive-procedure-objects)
560   (map (lambda (proc) (list 'primitive (cadr proc)))
561        primitive-procedures))
562 (define (apply-primitive-procedure proc args)
563   (apply
564    (primitive-implementation proc) args))
565 
566 ;; execute application
567 
568 (define (execute-application proc args succeed fail)
569   (cond ((primitive-procedure? proc)
570          (succeed (apply-primitive-procedure proc args)
571                   fail))
572         ((compound-procedure? proc)
573          ((procedure-body proc)
574           (extend-environment (procedure-parameters proc)
575                               args
576                               (procedure-environment proc))
577           succeed
578           fail))
579         (else
580          (error
581           "Unknown procedure type -- EXECUTE-APPLICATION"
582           proc))))
583 
584 
585 ;; driver-loop
586 (define (prompt-for-input string)
587   (newline) (newline) (display string) (newline))
588 (define (announce-output string)
589   (newline) (display string) (newline))
590 (define (user-print object)
591   (if (compound-procedure? object)
592       (display (list 'compound-procedure
593                      (procedure-parameters object)
594                      (procedure-body object)
595                      '<procedure-env>))
596       (display object)))
597 (define (setup-environment)
598   (let ((initial-env
599          (extend-environment (primitive-procedure-names)
600                              (primitive-procedure-objects)
601                              the-empty-environment)))
602     (define-variable! 'true true initial-env)
603     (define-variable! 'false false initial-env)
604     initial-env))
605 (define the-global-environment (setup-environment))
606 
607 (define input-prompt ";;; Amb-Eval input:")
608 (define output-prompt ";;; Amb-Eval value:")
609 (define (driver-loop)
610   (define (internal-loop try-again)
611     (prompt-for-input input-prompt)
612     (let ((input (read)))
613       (if (eq? input 'try-again)
614           (try-again)
615           (begin
616             (newline)
617             (display ";;; Starting a new problem ")
618             (ambeval input
619                      the-global-environment
620                      ;; ambeval success
621                      (lambda (val next-alternative)
622                        (announce-output output-prompt)
623                        (user-print val)
624                        (internal-loop next-alternative))
625                      ;; ambeval failure
626                      (lambda ()
627                        (announce-output
628                         ";;; There are no more values of")
629                        (user-print input)
630                        (driver-loop)))))))
631   (internal-loop
632    (lambda ()
633      (newline)
634      (display ";;; There is no current problem")
635      (driver-loop))))
636 
637 
638 ;; auxiliary
639 (define (test-case actual expected)
640   (newline)
641   (display "Actual:   ")
642   (display actual)
643   (newline)
644   (display "Expected: ")
645   (display expected)
646   (newline))
647 (define try-again
648   (lambda ()
649     "No current problem"))
650 (define (geval exp) ;; eval globally
651   (if (eq? exp 'try-again)
652       (try-again)
653       (ambeval exp 
654 	       the-global-environment
655 	       (lambda (val next-alternative)
656 		 (set! try-again next-alternative)
657 		 val)
658 	       (lambda ()
659 		 (set! try-again
660 		       (lambda ()
661 			 "No current problem"))
662 		 "No alternatives"))))
663 (define (test-eval exp expected)
664   (test-case (geval exp) expected))
665 
666 
667 ;; test-suite
668 
669 ;; procedure definitions
670 
671 (geval 
672  '(define (assoc key records)
673     (cond ((null? records) false)
674 	  ((equal? key (caar records)) (car records))
675 	  (else (assoc key (cdr records))))))
676 
677 (geval
678  '(define (map proc list)
679     (if (null? list)
680 	'()
681 	(cons (proc (car list))
682 	      (map proc (cdr list))))))
683 
684 (geval 
685  '(define (accumulate op initial sequence)
686     (if (null? sequence)
687 	initial
688 	(op (car sequence)
689 	    (accumulate op initial (cdr sequence))))))
690 
691 ;; ;; all special forms
692 (test-eval '(begin 5 6) 6)
693 (test-eval '10 10)
694 (geval '(define x 3))
695 (test-eval 'x 3)
696 (test-eval '(set! x -25) 'ok)
697 (test-eval 'x -25)
698 (geval '(define z (lambda (x y) (+ x (* x y)))))
699 (test-eval '(z 3 4) 15)
700 (test-eval '(cond ((= x -2) 'x=-2)
701 		  ((= x -25) 'x=-25)
702 		  (else 'failed))
703 	   'x=-25)
704 (test-eval '(if true false true) false)
705 
706 (test-eval 
707  '(let ((x 4) (y 7))
708     (+ x y (* x y)))
709  (+ 4 7 (* 4 7)))
710 
711 
712 ;; and/or
713 (geval '(define x (+ 3 8)))
714 (test-eval '(and 0 true x) 11)
715 (test-eval '(and 0 true x false) false)
716 (test-eval '(and 0 true x (set! x -2) false) false)
717 (test-eval 'x -2)
718 (test-eval '(and 0 true x false (set! x -5)) false)
719 (test-eval 'x -2)
720 (test-eval '(or false (set! x 25)) 'ok)
721 (test-eval 'x 25)
722 (test-eval '(or (set! x 2) (set! x 4)) 'ok)
723 (test-eval 'x 2)
724 (test-eval '(or false (set! x 25) true false) 'ok)
725 (test-eval 'x 25)
726 (test-eval '(or ((lambda (x) x) 5)) 5)
727 (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
728 (newline)
729 (display "Failure expected")
730 (newline)
731 
732 ;; cond
733 
734 (test-eval 
735  '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
736 	(else false))
737  2)
738 
739 (test-eval
740  '(cond ((= 3 4) 'not-true)
741 	((= (* 2 4) 3) 'also-false)
742 	((map (lambda (x)
743 		(* x (+ x 1)))
744 	      '(2 4 1 9))
745 	 =>
746 	 (lambda (x)
747 	   (accumulate + 0 x)))
748 	(else 'never-reach))
749  118)
750 ;; '(6 20 2 90)
751 
752 
753 ;; procedure definition and application
754 (geval
755  '(define (factorial n)
756     (if (= n 0)
757 	1
758 	(* n (factorial (- n 1))))))
759 (test-eval '(factorial 5) 120)
760 
761 ;; map
762 
763 (test-eval
764  '(map (lambda (x)
765 	 (* x (+ x 1)))
766        '(2 1 4 2 8 3))
767  '(6 2 20 6 72 12))
768 ;; accumulate
769 
770 (test-eval
771  '(accumulate + 0 '(1 2 3 4 5))
772  15)
773 
774 ;; make-let
775 (test-eval 
776  (make-let '(x y) '(3 5) '((+ x y)))
777  8)
778 (test-eval 
779  '(let ()
780     5)
781  5)
782 (test-eval
783  '(let ((x 3))
784     x)
785  3)
786 (test-eval
787  '(let ((x 3)
788 	(y 5))
789     (+ x y))
790  8)
791 (test-eval 
792  '(let ((x 3)
793 	(y 2))
794     (+ (let ((x (+ y 2))
795 	     (y x))
796 	 (* x y))
797        x y))
798  (+ (* 4 3) 3 2))
799 (test-eval
800  '(let ((x 6)
801 	(y (let ((x 2))
802 	     (+ x 3)))
803 	(z (let ((a (* 3 2)))
804 	     (+ a 3))))
805     (+ x y z))
806  (+ 6 5 9))
807     
808 
809 ;; let*
810 
811 (test-eval
812  '(let* ((x 3)
813 	 (y (+ x 2))
814 	 (z (+ x y 5)))
815     (* x z))
816  39)
817 
818 (test-eval
819  '(let* ()
820     5)
821  5)
822 (test-eval
823  '(let* ((x 3))
824     (let* ((y 5))
825       (+ x y)))
826  8)
827 
828 (test-eval 
829  '(let* ((x 3)
830 	 (y (+ x 1)))
831     (+ (let* ((x (+ y 2))
832 	      (y x))
833 	 (* x y))
834        x y))
835  (+ (* 6 6) 3 4))
836 (test-eval
837  '(let* ((x 6)
838 	 (y (let* ((x 2)
839 		   (a (let* ((x (* 3 x)))
840 			(+ x 2))))       
841 	      (+ x a)))                  
842 	 (z (+ x y)))                    
843     (+ x y z))
844  32)
845 
846 ;; named-let
847 
848 (test-eval
849  '(let eight ()
850     5
851     7
852     8)
853  8)
854 (test-eval
855  '(let loop ((count 0))
856     (if (= 100 count)
857 	count
858 	(loop (+ count 1))))
859  100)
860 (geval
861  '(define (prime? x)
862     (let prime-iter ((i 2))
863       (cond ((> (* i i) x) true)
864 	    ((= (remainder x i) 0) false)
865 	    (else (prime-iter (+ i 1)))))))
866 (test-eval
867  '(let primes ((x 2)
868 	       (n 20))
869     (cond ((= n 0) '())
870 	  ((prime? x) 
871 	   (cons x
872 		 (primes (+ x 1) (- n 1))))
873 	  (else (primes (+ x 1) n))))
874  '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
875 
876 (geval
877  '(define (fib n)
878     (let fib-iter ((a 1)
879 		   (b 0)
880 		   (count n))
881       (if (= count 0)
882 	  b
883 	  (fib-iter (+ a b) a (- count 1))))))
884 (test-eval '(fib 19) 4181)
885 
886 ;; do-loop	  
887 (test-eval
888  '(let ((y 0))
889     (do ((x 0 (+ x 1)))
890 	((= x 5) y)
891       (set! y (+ y 1))))
892  5)
893 (test-eval
894  '(do ()
895       (true))
896  true)
897 (test-eval
898  '(do ()
899       (true 5))
900  5)
901 (test-eval
902  '(let ((y 0))
903     (do ()
904 	((= y 5) y)
905       (set! y (+ y 1))))
906  5)
907 
908 (test-eval
909  '(do ((y '(1 2 3 4)))
910       ((null? y))
911     (set! y (cdr y)))
912  true)
913 (test-eval
914  '(let ((y 0))
915     (do ((x 0 (+ x 1)))
916 	((= x 5) y)
917       (set! y (+ y 1))))
918  5)
919 (test-eval
920  '(let ((x '(1 3 5 7 9)))
921     (do ((x x (cdr x))
922 	 (sum 0 (+ sum (car x))))
923 	((null? x) sum)))
924  25)
925 (test-eval 
926  '(let ((z '()))
927     (do ((x '(1 2 3 4) (cdr x))
928 	 (y '(1 2 3 4 5 6 7 8) (cddr y)))
929 	((null? x) y x z)
930       (set! z (cons (car x) z))))
931  '(4 3 2 1))
932 
933 
934 
935 ;; make-unbound!
936 ;; broken now due to scan-out-defines
937 
938 ;; (test-eval
939 ;;  '(let ((x 3))
940 ;;     (let ((x 5))
941 ;;       (make-unbound! x)
942 ;;       (* x x)))
943 ;;  9)
944 
945 ;; (test-eval
946 ;;  '(let ((x 3))
947 ;;     (let ((x 5))
948 ;;       (define y x)
949 ;;       (make-unbound! x)
950 ;;       (* y x)))
951 ;;  15)
952 
953 ;; (test-eval
954 ;;  '(let ((y -1) (x 3))
955 ;;     (let ((y 0.5) (x 5))
956 ;;       (define a x)
957 ;;       (define b y)
958 ;;       (make-unbound! x)
959 ;;       (make-unbound! y)
960 ;;       (* a b x y)))
961 ;;  (* 5 3 -1 0.5))
962 
963 ;; (test-eval
964 ;;  '(let ((x 3) (y 4))
965 ;;     (let ((x 5))
966 ;;       (make-unbound! x)
967 ;;       (+ x 4)))
968 ;;  7)
969 
970 ;; (test-eval 
971 ;;  '(let ((a 1) (b 2) (c 3) (d 4))
972 ;;     (make-unbound! b)
973 ;;     (+ a c d))
974 ;;  (+ 1 3 4))
975 
976 ;; (test-eval
977 ;;  '(let ((x 4) (y 5))
978 ;;     (let ((a 1) (b 2) (c 3))
979 ;;       (let ((x (+ a b)) (y (+ c a)))
980 ;; 	(make-unbound! x)
981 ;; 	(let ((a x) (b (+ x y)))
982 ;; 	  (define z b)
983 ;; 	  (make-unbound! b)
984 ;; 	  (* (+ a z)
985 ;; 	     (+ a b y))))))
986 ;;  (* (+ 4 8)
987 ;;     (+ 4 2 4)))
988  
989 ;; x 3 -- y 4
990 ;; x 4 -- y 4
991 ;; a 4 -- b 4
992 ;; a 4 -- b 2
993 
994 ;; scan-out-defines
995 
996 (geval
997  '(define (f x)
998     (define (even? n)
999       (if (= n 0)
1000 	  true
1001 	  (odd? (- n 1))))
1002     (define (odd? n)
1003       (if (= n 0)
1004 	  false
1005 	  (even? (- n 1))))
1006     (even? x)))
1007 (test-eval '(f 5) false)
1008 (test-eval '(f 10) true)
1009 
1010 ;; ;; (geval
1011 ;; ;;  '(let ((x 5))
1012 ;; ;;     (define y x)
1013 ;; ;;     (define x 3)
1014 ;; ;;     (+ x y)))
1015 ;; ;; signal an error because x is undefined if variables are scanned out
1016 
1017 ;; ;; letrec
1018 
1019 ;; (geval
1020 ;;  '(define (f x)
1021 ;;     (letrec ((even?
1022 ;; 	      (lambda (n)
1023 ;; 		(if (= n 0)
1024 ;; 		    true
1025 ;; 		    (odd? (- n 1)))))
1026 ;; 	     (odd?
1027 ;; 	      (lambda (n)
1028 ;; 		(if (= n 0)
1029 ;; 		    false
1030 ;; 		    (even? (- n 1))))))
1031 ;;       (even? x))))
1032 ;; (test-eval '(f 11) false)
1033 ;; (test-eval '(f 16) true)
1034 
1035 ;; (test-eval 
1036 ;;  '(letrec ((fact
1037 ;; 	    (lambda (n)
1038 ;; 	      (if (= n 1)
1039 ;; 		  1
1040 ;; 		  (* n (fact (- n 1)))))))
1041 ;;     (fact 10))
1042 ;;  3628800)
1043 
1044 ;; amb
1045 (test-eval '(amb 1 2 3) 1)
1046 (test-eval 'try-again 2)
1047 (test-eval 'try-again 3)
1048 (test-eval 'try-again "No alternatives")
1049 (test-eval 'try-again "No current problem")
1050 (test-eval 'try-again "No current problem")
1051 (test-eval '(amb (amb 1 2) (amb 'a 'b))
1052 	   1)
1053 (test-eval 'try-again 2)
1054 (test-eval 'try-again 'a)
1055 (test-eval 'try-again 'b)
1056 (test-eval 'try-again "No alternatives")
1057 (geval '(define (require p) (if (not p) (amb))))
1058 (test-eval '(require false) "No alternatives")
1059 (test-eval '(require true) false)
1060 
1061 	   
1062 (geval
1063  '(define (an-integer-between low high)
1064     (require (<= low high))
1065     (amb low (an-integer-between (+ low 1) high))))
1066 
1067 (geval 
1068  '(define (a-pythagorean-triple-between low high)
1069     (let ((i (an-integer-between low high)))
1070       (let ((j (an-integer-between i high)))
1071 	(let ((k (an-integer-between j high)))
1072 	  (require (= (+ (* i i) (* j j)) (* k k)))
1073 	  (list i j k))))))
1074 
1075 ;; (test-eval
1076 ;;  '(a-pythagorean-triple-between 1 20)
1077 ;;  '(3 4 5))
1078 ;; (test-eval 'try-again '(5 12 13))
1079 ;; (test-eval 'try-again '(6 8 10))
1080 ;; (test-eval 'try-again '(8 15 17))
1081 ;; (test-eval 'try-again '(9 12 15))
1082 
1083 (geval
1084  '(define (an-integer-starting-from low)
1085     (amb low (an-integer-starting-from (+ low 1)))))
1086 
1087 (geval
1088  '(define (pythagorean-triples-starting-from low)
1089     (let* ((k (an-integer-starting-from low))
1090 	   (i (an-integer-between low k))
1091 	   (j (an-integer-between i k)))
1092       (require (= (+ (* i i) (* j j)) (* k k)))
1093       (list i j k))))
1094 
1095 ;; (test-eval '(pythagorean-triples-starting-from 1)
1096 ;; 	   '(3 4 5))
1097 ;; (test-eval 'try-again '(6 8 10))
1098 ;; (test-eval 'try-again '(5 12 13))
1099 ;; (test-eval 'try-again '(9 12 15))
1100 ;; (test-eval 'try-again '(8 15 17))
1101 
1102 (geval
1103  '(define (next-triplet trp)
1104     (let ((i (car trp))
1105 	  (j (cadr trp))
1106 	  (k (caddr trp)))
1107       (cond ((= i j k) (list 1 1 (+ k 1)))
1108 	    ((= j k) (list (+ i 1) (+ i 1) k))
1109 	    (else (list i (+ j 1) k))))))
1110 (geval
1111  '(define (triplet-starting-from trp)
1112     (amb trp (triplet-starting-from (next-triplet trp)))))
1113 (geval
1114  '(define (pythagorean-triples-starting-from low)
1115     (let* ((triplet (triplet-starting-from (list low low low)))
1116 	   (i (car triplet))
1117 	   (j (cadr triplet))
1118 	   (k (caddr triplet)))
1119       (require (= (+ (* i i) (* j j)) (* k k)))
1120       (list i j k))))
1121 (geval
1122  '(define (distinct? items)
1123     (cond ((null? items) true)
1124 	  ((null? (cdr items)) true)
1125 	  ((member (car items) (cdr items)) false)
1126 	  (else (distinct? (cdr items))))))
1127 
1128 ;;  Exercise 4.43.  Use the amb evaluator to solve the following puzzle:49
1129 
1130 ;;     Mary Ann Moore's father has a yacht and so has each of his four friends: Colonel Downing, Mr. Hall, Sir Barnacle Hood, and Dr. Parker. Each of the five also has one daughter and each has named his yacht after a daughter of one of the others. Sir Barnacle's yacht is the Gabrielle, Mr. Moore owns the Lorna; Mr. Hall the Rosalind. The Melissa, owned by Colonel Downing, is named after Sir Barnacle's daughter.
1131 ;; Gabrielle's father owns the yacht that is named after Dr. Parker's daughter. Who is Lorna's father? 
1132 
1133 ;; Try to write the program so that it runs efficiently (see exercise 4.40). Also determine how many solutions there are if we are not told that Mary Ann's last name is Moore. 
1134 
1135 ;;barnacle - mellisa
1136 ;;(moore downing hall barnacle-hood parker)
1137 ;;		       ((eq? gabrielle 'hall) ...))
1138 
1139 (geval 
1140  '(define (yacht)
1141     (let* ((mary-ann 'moore)
1142 	   (melissa 'barnacle-hood)
1143 	   (gabrielle (amb 'downing 'hall))
1144 	   (lorna (amb 'downing 'hall 'parker)))
1145       (require (not (eq? gabrielle lorna)))
1146       (let ((rosalind (amb 'downing 'parker)))
1147 	(require (not (member rosalind (list gabrielle lorna))))
1148 	(require (if (eq? gabrielle 'downing)
1149 		     (eq? lorna 'parker)
1150 		     (eq? rosalind 'parker)))
1151 ;;	(require (distinct? (list mary-ann melissa gabrielle lorna rosalind)))
1152 	(list 'lorna lorna)))))
1153 
1154 (user-print (geval '(yacht)))
1155 (newline)
1156 (user-print (geval 'try-again))
1157 (user-print (geval 'try-again))
1158 (user-print (geval 'try-again))
1159 (user-print (geval 'try-again))
1160 (user-print (geval 'try-again))
1161 
1162