Blob


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))))
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))))
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)))
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))))
151 (define (tagged-list? exp tag)
152 (if (pair? exp)
153 (eq? (car exp) tag)
154 false))
156 ;; amb
157 (define (amb? exp) (tagged-list? exp 'amb))
158 (define (amb-choices exp) (cdr exp))
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))
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))
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))
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))
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)))
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))))
278 (define (letrec? exp)
279 (tagged-list? exp 'letrec))
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))))
301 (define (make-application op args)
302 (cons op args))
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))))
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)))))))))
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))
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))
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))
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))
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))))
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))))
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 'abs abs)
543 (list 'remainder remainder)
544 (list 'eq? eq?)
545 (list 'equal? equal?)
546 (list 'member member)
547 (list 'display display)))
548 (define (primitive-procedure-names)
549 (map car
550 primitive-procedures))
551 (define (primitive-procedure-objects)
552 (map (lambda (proc) (list 'primitive (cadr proc)))
553 primitive-procedures))
554 (define (apply-primitive-procedure proc args)
555 (apply
556 (primitive-implementation proc) args))
558 ;; execute application
560 (define (execute-application proc args succeed fail)
561 (cond ((primitive-procedure? proc)
562 (succeed (apply-primitive-procedure proc args)
563 fail))
564 ((compound-procedure? proc)
565 ((procedure-body proc)
566 (extend-environment (procedure-parameters proc)
567 args
568 (procedure-environment proc))
569 succeed
570 fail))
571 (else
572 (error
573 "Unknown procedure type -- EXECUTE-APPLICATION"
574 proc))))
577 ;; driver-loop
578 (define (prompt-for-input string)
579 (newline) (newline) (display string) (newline))
580 (define (announce-output string)
581 (newline) (display string) (newline))
582 (define (user-print object)
583 (if (compound-procedure? object)
584 (display (list 'compound-procedure
585 (procedure-parameters object)
586 (procedure-body object)
587 '<procedure-env>))
588 (display object)))
589 (define (setup-environment)
590 (let ((initial-env
591 (extend-environment (primitive-procedure-names)
592 (primitive-procedure-objects)
593 the-empty-environment)))
594 (define-variable! 'true true initial-env)
595 (define-variable! 'false false initial-env)
596 initial-env))
597 (define the-global-environment (setup-environment))
599 (define input-prompt ";;; Amb-Eval input:")
600 (define output-prompt ";;; Amb-Eval value:")
601 (define (driver-loop)
602 (define (internal-loop try-again)
603 (prompt-for-input input-prompt)
604 (let ((input (read)))
605 (if (eq? input 'try-again)
606 (try-again)
607 (begin
608 (newline)
609 (display ";;; Starting a new problem ")
610 (ambeval input
611 the-global-environment
612 ;; ambeval success
613 (lambda (val next-alternative)
614 (announce-output output-prompt)
615 (user-print val)
616 (internal-loop next-alternative))
617 ;; ambeval failure
618 (lambda ()
619 (announce-output
620 ";;; There are no more values of")
621 (user-print input)
622 (driver-loop)))))))
623 (internal-loop
624 (lambda ()
625 (newline)
626 (display ";;; There is no current problem")
627 (driver-loop))))
630 ;; auxiliary
631 (define (test-case actual expected)
632 (newline)
633 (display "Actual: ")
634 (display actual)
635 (newline)
636 (display "Expected: ")
637 (display expected)
638 (newline))
639 (define try-again
640 (lambda ()
641 "No current problem"))
642 (define (geval exp) ;; eval globally
643 (if (eq? exp 'try-again)
644 (try-again)
645 (ambeval exp
646 the-global-environment
647 (lambda (val next-alternative)
648 (set! try-again next-alternative)
649 val)
650 (lambda ()
651 (set! try-again
652 (lambda ()
653 "No current problem"))
654 "No alternatives"))))
655 (define (test-eval exp expected)
656 (test-case (geval exp) expected))
659 ;; test-suite
661 ;; procedure definitions
663 (geval
664 '(define (assoc key records)
665 (cond ((null? records) false)
666 ((equal? key (caar records)) (car records))
667 (else (assoc key (cdr records))))))
669 (geval
670 '(define (map proc list)
671 (if (null? list)
672 '()
673 (cons (proc (car list))
674 (map proc (cdr list))))))
676 (geval
677 '(define (accumulate op initial sequence)
678 (if (null? sequence)
679 initial
680 (op (car sequence)
681 (accumulate op initial (cdr sequence))))))
683 ;; ;; all special forms
684 (test-eval '(begin 5 6) 6)
685 (test-eval '10 10)
686 (geval '(define x 3))
687 (test-eval 'x 3)
688 (test-eval '(set! x -25) 'ok)
689 (test-eval 'x -25)
690 (geval '(define z (lambda (x y) (+ x (* x y)))))
691 (test-eval '(z 3 4) 15)
692 (test-eval '(cond ((= x -2) 'x=-2)
693 ((= x -25) 'x=-25)
694 (else 'failed))
695 'x=-25)
696 (test-eval '(if true false true) false)
698 (test-eval
699 '(let ((x 4) (y 7))
700 (+ x y (* x y)))
701 (+ 4 7 (* 4 7)))
704 ;; and/or
705 (geval '(define x (+ 3 8)))
706 (test-eval '(and 0 true x) 11)
707 (test-eval '(and 0 true x false) false)
708 (test-eval '(and 0 true x (set! x -2) false) false)
709 (test-eval 'x -2)
710 (test-eval '(and 0 true x false (set! x -5)) false)
711 (test-eval 'x -2)
712 (test-eval '(or false (set! x 25)) 'ok)
713 (test-eval 'x 25)
714 (test-eval '(or (set! x 2) (set! x 4)) 'ok)
715 (test-eval 'x 2)
716 (test-eval '(or false (set! x 25) true false) 'ok)
717 (test-eval 'x 25)
718 (test-eval '(or ((lambda (x) x) 5)) 5)
719 (test-eval '(or (begin (set! x (+ x 1)) x)) 26) ;; this fails because or->if repeats the same clause twice
720 (newline)
721 (display "Failure expected")
722 (newline)
724 ;; cond
726 (test-eval
727 '(cond ((assoc 'b '((a 1) (b 2))) => cadr)
728 (else false))
729 2)
731 (test-eval
732 '(cond ((= 3 4) 'not-true)
733 ((= (* 2 4) 3) 'also-false)
734 ((map (lambda (x)
735 (* x (+ x 1)))
736 '(2 4 1 9))
737 =>
738 (lambda (x)
739 (accumulate + 0 x)))
740 (else 'never-reach))
741 118)
742 ;; '(6 20 2 90)
745 ;; procedure definition and application
746 (geval
747 '(define (factorial n)
748 (if (= n 0)
750 (* n (factorial (- n 1))))))
751 (test-eval '(factorial 5) 120)
753 ;; map
755 (test-eval
756 '(map (lambda (x)
757 (* x (+ x 1)))
758 '(2 1 4 2 8 3))
759 '(6 2 20 6 72 12))
760 ;; accumulate
762 (test-eval
763 '(accumulate + 0 '(1 2 3 4 5))
764 15)
766 ;; make-let
767 (test-eval
768 (make-let '(x y) '(3 5) '((+ x y)))
769 8)
770 (test-eval
771 '(let ()
772 5)
773 5)
774 (test-eval
775 '(let ((x 3))
776 x)
777 3)
778 (test-eval
779 '(let ((x 3)
780 (y 5))
781 (+ x y))
782 8)
783 (test-eval
784 '(let ((x 3)
785 (y 2))
786 (+ (let ((x (+ y 2))
787 (y x))
788 (* x y))
789 x y))
790 (+ (* 4 3) 3 2))
791 (test-eval
792 '(let ((x 6)
793 (y (let ((x 2))
794 (+ x 3)))
795 (z (let ((a (* 3 2)))
796 (+ a 3))))
797 (+ x y z))
798 (+ 6 5 9))
801 ;; let*
803 (test-eval
804 '(let* ((x 3)
805 (y (+ x 2))
806 (z (+ x y 5)))
807 (* x z))
808 39)
810 (test-eval
811 '(let* ()
812 5)
813 5)
814 (test-eval
815 '(let* ((x 3))
816 (let* ((y 5))
817 (+ x y)))
818 8)
820 (test-eval
821 '(let* ((x 3)
822 (y (+ x 1)))
823 (+ (let* ((x (+ y 2))
824 (y x))
825 (* x y))
826 x y))
827 (+ (* 6 6) 3 4))
828 (test-eval
829 '(let* ((x 6)
830 (y (let* ((x 2)
831 (a (let* ((x (* 3 x)))
832 (+ x 2))))
833 (+ x a)))
834 (z (+ x y)))
835 (+ x y z))
836 32)
838 ;; named-let
840 (test-eval
841 '(let eight ()
844 8)
845 8)
846 (test-eval
847 '(let loop ((count 0))
848 (if (= 100 count)
849 count
850 (loop (+ count 1))))
851 100)
852 (geval
853 '(define (prime? x)
854 (let prime-iter ((i 2))
855 (cond ((> (* i i) x) true)
856 ((= (remainder x i) 0) false)
857 (else (prime-iter (+ i 1)))))))
858 (test-eval
859 '(let primes ((x 2)
860 (n 20))
861 (cond ((= n 0) '())
862 ((prime? x)
863 (cons x
864 (primes (+ x 1) (- n 1))))
865 (else (primes (+ x 1) n))))
866 '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47 53 59 61 67 71))
868 (geval
869 '(define (fib n)
870 (let fib-iter ((a 1)
871 (b 0)
872 (count n))
873 (if (= count 0)
875 (fib-iter (+ a b) a (- count 1))))))
876 (test-eval '(fib 19) 4181)
878 ;; do-loop
879 (test-eval
880 '(let ((y 0))
881 (do ((x 0 (+ x 1)))
882 ((= x 5) y)
883 (set! y (+ y 1))))
884 5)
885 (test-eval
886 '(do ()
887 (true))
888 true)
889 (test-eval
890 '(do ()
891 (true 5))
892 5)
893 (test-eval
894 '(let ((y 0))
895 (do ()
896 ((= y 5) y)
897 (set! y (+ y 1))))
898 5)
900 (test-eval
901 '(do ((y '(1 2 3 4)))
902 ((null? y))
903 (set! y (cdr y)))
904 true)
905 (test-eval
906 '(let ((y 0))
907 (do ((x 0 (+ x 1)))
908 ((= x 5) y)
909 (set! y (+ y 1))))
910 5)
911 (test-eval
912 '(let ((x '(1 3 5 7 9)))
913 (do ((x x (cdr x))
914 (sum 0 (+ sum (car x))))
915 ((null? x) sum)))
916 25)
917 (test-eval
918 '(let ((z '()))
919 (do ((x '(1 2 3 4) (cdr x))
920 (y '(1 2 3 4 5 6 7 8) (cddr y)))
921 ((null? x) y x z)
922 (set! z (cons (car x) z))))
923 '(4 3 2 1))
927 ;; make-unbound!
928 ;; broken now due to scan-out-defines
930 ;; (test-eval
931 ;; '(let ((x 3))
932 ;; (let ((x 5))
933 ;; (make-unbound! x)
934 ;; (* x x)))
935 ;; 9)
937 ;; (test-eval
938 ;; '(let ((x 3))
939 ;; (let ((x 5))
940 ;; (define y x)
941 ;; (make-unbound! x)
942 ;; (* y x)))
943 ;; 15)
945 ;; (test-eval
946 ;; '(let ((y -1) (x 3))
947 ;; (let ((y 0.5) (x 5))
948 ;; (define a x)
949 ;; (define b y)
950 ;; (make-unbound! x)
951 ;; (make-unbound! y)
952 ;; (* a b x y)))
953 ;; (* 5 3 -1 0.5))
955 ;; (test-eval
956 ;; '(let ((x 3) (y 4))
957 ;; (let ((x 5))
958 ;; (make-unbound! x)
959 ;; (+ x 4)))
960 ;; 7)
962 ;; (test-eval
963 ;; '(let ((a 1) (b 2) (c 3) (d 4))
964 ;; (make-unbound! b)
965 ;; (+ a c d))
966 ;; (+ 1 3 4))
968 ;; (test-eval
969 ;; '(let ((x 4) (y 5))
970 ;; (let ((a 1) (b 2) (c 3))
971 ;; (let ((x (+ a b)) (y (+ c a)))
972 ;; (make-unbound! x)
973 ;; (let ((a x) (b (+ x y)))
974 ;; (define z b)
975 ;; (make-unbound! b)
976 ;; (* (+ a z)
977 ;; (+ a b y))))))
978 ;; (* (+ 4 8)
979 ;; (+ 4 2 4)))
981 ;; x 3 -- y 4
982 ;; x 4 -- y 4
983 ;; a 4 -- b 4
984 ;; a 4 -- b 2
986 ;; scan-out-defines
988 (geval
989 '(define (f x)
990 (define (even? n)
991 (if (= n 0)
992 true
993 (odd? (- n 1))))
994 (define (odd? n)
995 (if (= n 0)
996 false
997 (even? (- n 1))))
998 (even? x)))
999 (test-eval '(f 5) false)
1000 (test-eval '(f 10) true)
1002 ;; ;; (geval
1003 ;; ;; '(let ((x 5))
1004 ;; ;; (define y x)
1005 ;; ;; (define x 3)
1006 ;; ;; (+ x y)))
1007 ;; ;; signal an error because x is undefined if variables are scanned out
1009 ;; ;; letrec
1011 ;; (geval
1012 ;; '(define (f x)
1013 ;; (letrec ((even?
1014 ;; (lambda (n)
1015 ;; (if (= n 0)
1016 ;; true
1017 ;; (odd? (- n 1)))))
1018 ;; (odd?
1019 ;; (lambda (n)
1020 ;; (if (= n 0)
1021 ;; false
1022 ;; (even? (- n 1))))))
1023 ;; (even? x))))
1024 ;; (test-eval '(f 11) false)
1025 ;; (test-eval '(f 16) true)
1027 ;; (test-eval
1028 ;; '(letrec ((fact
1029 ;; (lambda (n)
1030 ;; (if (= n 1)
1031 ;; 1
1032 ;; (* n (fact (- n 1)))))))
1033 ;; (fact 10))
1034 ;; 3628800)
1036 ;; amb
1037 (test-eval '(amb 1 2 3) 1)
1038 (test-eval 'try-again 2)
1039 (test-eval 'try-again 3)
1040 (test-eval 'try-again "No alternatives")
1041 (test-eval 'try-again "No current problem")
1042 (test-eval 'try-again "No current problem")
1043 (test-eval '(amb (amb 1 2) (amb 'a 'b))
1045 (test-eval 'try-again 2)
1046 (test-eval 'try-again 'a)
1047 (test-eval 'try-again 'b)
1048 (test-eval 'try-again "No alternatives")
1049 (geval '(define (require p) (if (not p) (amb))))
1050 (test-eval '(require false) "No alternatives")
1051 (test-eval '(require true) false)
1054 (geval
1055 '(define (an-integer-between low high)
1056 (require (<= low high))
1057 (amb low (an-integer-between (+ low 1) high))))
1059 (geval
1060 '(define (a-pythagorean-triple-between low high)
1061 (let ((i (an-integer-between low high)))
1062 (let ((j (an-integer-between i high)))
1063 (let ((k (an-integer-between j high)))
1064 (require (= (+ (* i i) (* j j)) (* k k)))
1065 (list i j k))))))
1067 ;; (test-eval
1068 ;; '(a-pythagorean-triple-between 1 20)
1069 ;; '(3 4 5))
1070 ;; (test-eval 'try-again '(5 12 13))
1071 ;; (test-eval 'try-again '(6 8 10))
1072 ;; (test-eval 'try-again '(8 15 17))
1073 ;; (test-eval 'try-again '(9 12 15))
1075 (geval
1076 '(define (an-integer-starting-from low)
1077 (amb low (an-integer-starting-from (+ low 1)))))
1079 (geval
1080 '(define (pythagorean-triples-starting-from low)
1081 (let* ((k (an-integer-starting-from low))
1082 (i (an-integer-between low k))
1083 (j (an-integer-between i k)))
1084 (require (= (+ (* i i) (* j j)) (* k k)))
1085 (list i j k))))
1087 ;; (test-eval '(pythagorean-triples-starting-from 1)
1088 ;; '(3 4 5))
1089 ;; (test-eval 'try-again '(6 8 10))
1090 ;; (test-eval 'try-again '(5 12 13))
1091 ;; (test-eval 'try-again '(9 12 15))
1092 ;; (test-eval 'try-again '(8 15 17))
1094 (geval
1095 '(define (next-triplet trp)
1096 (let ((i (car trp))
1097 (j (cadr trp))
1098 (k (caddr trp)))
1099 (cond ((= i j k) (list 1 1 (+ k 1)))
1100 ((= j k) (list (+ i 1) (+ i 1) k))
1101 (else (list i (+ j 1) k))))))
1102 (geval
1103 '(define (triplet-starting-from trp)
1104 (amb trp (triplet-starting-from (next-triplet trp)))))
1105 (geval
1106 '(define (pythagorean-triples-starting-from low)
1107 (let* ((triplet (triplet-starting-from (list low low low)))
1108 (i (car triplet))
1109 (j (cadr triplet))
1110 (k (caddr triplet)))
1111 (require (= (+ (* i i) (* j j)) (* k k)))
1112 (list i j k))))
1115 ;; (test-eval '(pythagorean-triples-starting-from 1)
1116 ;; '(3 4 5))
1117 ;; (test-eval 'try-again '(6 8 10))
1118 ;; (test-eval 'try-again '(5 12 13))
1119 ;; (test-eval 'try-again '(9 12 15))
1120 ;; (test-eval 'try-again '(8 15 17))
1122 ;; (geval
1123 ;; '(define (multiple-dwelling)
1124 ;; (let ((baker (amb 1 2 3 4 5))
1125 ;; (cooper (amb 1 2 3 4 5))
1126 ;; (fletcher (amb 1 2 3 4 5))
1127 ;; (miller (amb 1 2 3 4 5))
1128 ;; (smith (amb 1 2 3 4 5)))
1129 ;; (require
1130 ;; (distinct? (list baker cooper fletcher miller smith)))
1131 ;; (require (not (= baker 5)))
1132 ;; (require (not (= cooper 1)))
1133 ;; (require (not (= fletcher 5)))
1134 ;; (require (not (= fletcher 1)))
1135 ;; (require (> miller cooper))
1136 ;; (require (not (= (abs (- smith fletcher)) 1)))
1137 ;; (require (not (= (abs (- fletcher cooper)) 1)))
1138 ;; (list (list 'baker baker)
1139 ;; (list 'cooper cooper)
1140 ;; (list 'fletcher fletcher)
1141 ;; (list 'miller miller)
1142 ;; (list 'smith smith)))))
1143 (geval
1144 '(define (distinct? items)
1145 (cond ((null? items) true)
1146 ((null? (cdr items)) true)
1147 ((member (car items) (cdr items)) false)
1148 (else (distinct? (cdr items))))))
1149 ;; (test-eval '(multiple-dwelling)
1150 ;; '((baker 3) (cooper 2) (fletcher 4) (miller 5) (smith 1)))
1152 ;; Exercise 4.39. Does the order of the restrictions in the multiple-dwelling procedure affect the answer? Does it affect the time to find an answer? If you think it matters, demonstrate a faster program obtained from the given one by reordering the restrictions. If you think it does not matter, argue your case.
1154 ;; the order doesn't matter as for correctness, but it does affect speed
1155 ;; require is slow because it must, for each element, check through all the remaining elements
1157 (geval
1158 '(define (multiple-dwelling)
1159 (let ((baker (amb 1 2 3 4 5))
1160 (cooper (amb 1 2 3 4 5))
1161 (fletcher (amb 1 2 3 4 5))
1162 (miller (amb 1 2 3 4 5))
1163 (smith (amb 1 2 3 4 5)))
1164 (require (> miller cooper))
1165 (require (not (= baker 5)))
1166 (require (not (= cooper 1)))
1167 (require (not (= fletcher 5)))
1168 (require (not (= fletcher 1)))
1169 (require (not (= (abs (- smith fletcher)) 1)))
1170 (require (not (= (abs (- fletcher cooper)) 1)))
1171 (require
1172 (distinct? (list baker cooper fletcher miller smith)))
1173 (list (list 'baker baker)
1174 (list 'cooper cooper)
1175 (list 'fletcher fletcher)
1176 (list 'miller miller)
1177 (list 'smith smith)))))
1179 ;; this is going to be significantly faster